perm filename GOGOL.SMI[SAI,TES] blob
sn#049717 filedate 1973-06-18 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00054 PAGES VERSION 16-2(58)
00200 RECORD PAGE DESCRIPTION
00300 00001 00001
00400 00005 00002 HISTORY
00500 00010 00003 Command File Descriptions
00600 00012 00004 Conditional Assembly Switches, Macros
00700 00016 00005 Titles, Versions
00800 00017 00006 AC Definitions
00900 00018 00007 CDB, SIMIO Indices For IOSER, OTHER INDICES
01000 00022 00008 Base (Low Segment) Data Descriptions -- Macros, Compil spec
01100 00024 00009 Base (Low Segment) Data Descriptions - Params, Links, Size specs
01200 00032 00010 Initialization Routines, Data
01300 00034 00011 Sailor, Reent -- Allocation, Main Program Control
01400 00037 00012 .SEG2. -- Get a second segment
01500 00040 00013
01600 00043 00014
01700 00046 00015
01800 00047 00016 Segment-Fetching Data
01900 00050 00017
02000 00051 00018 %ALLOC -- Main Allocation Routine
02100 00057 00019
02200 00064 00020
02300 00068 00021
02400 00071 00022 Utility Subroutines for allocation
02500 00073 00023 %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
02600 00075 00024 ILLUUO, PDLOV, ERR UUO Handlers
02700 00080 00025
02800 00083 00026 Special Printing Routines For Error Handler
02900 00086 00027 Code to Handle Linkage to Editors
03000 00089 00028
03100 00093 00029 DECPNT, OCTPNT, FIX, FLOAT UUOs
03200 00095 00030 DSPLIN, etc.for Disp. Text Line on Error (Compiler)
03300 00096 00031 SAVE, RESTR, INSET -- General Utility Routines
03400 00100 00032 Core Service Routines -- General Description
03500 00104 00033 Special AC Declarations
03600 00105 00034 Utility Routines
03700 00110 00035
03800 00114 00036 CORGET
03900 00118 00037
04000 00120 00038 CORINC, CANINC
04100 00125 00039 CORREL
04200 00130 00040 CORPRT, CORBIG
04300 00133 00041 String Garbage Collector Routines
04400 00138 00042
04500 00141 00043
04600 00146 00044
04700 00150 00045
04800 00154 00046
04900 00156 00047
05000 00158 00048
05100 00160 00049 Some Runtime Routines Which Could Go Nowhere Else
05200 00161 00050 Kounter Routines
05300 00163 00051
05400 00169 00052
05500 00171 00053
05600 00172 00054
05700 00174 ENDMK
05800 ⊗;
00100 COMMENT ⊗HISTORY
00200 AUTHOR,FAIL,REASON
00300 031 202000000072 ⊗;
00400 DEFINE .VERSION <202000000072>
00500
00600 COMMENT ⊗
00700 VERSION 16-2(58) 1-8-73 BY JRL BUG #KV# CHECK FOR NULL INILNK IN .UNIT
00800 VERSION 16-2(57) 12-2-72 BY RHT ENLARGE HERE TABLE
00900 VERSION 16-2(56) 12-1-72 BY RHT ADD DEFSSS,DEFPSS,DEFQNT,DEFPRI TO XX AREA
01000 VERSION 16-2(55) 11-30-72 BY RHT ADD XX ENTRY FOR NOPOLL
01100 VERSION 16-2(54) 11-22-72 BY JRL BUG #KL# STACSV SAVED TOO MANY AC'S IN TOO FEW LOCATIONS
01200 VERSION 16-2(53) 11-22-72
01300 VERSION 16-2(52) 11-22-72
01400 VERSION 16-2(51) 11-17-72 BY RHT MAKE USER INITIALIZATION A SEPARATE PROCEDURE
01500 VERSION 16-2(50) 11-10-72 BY JRL ADD PROPS TO XX AREA
01600 VERSION 16-2(49) 10-12-72 BY RHT ADD PPMAX FOR EXPO VERSION (NEEDED BY ED LNKG)
01700 VERSION 16-2(48) 10-5-72 BY JRL MAKE GLUSER INTERNAL
01800 VERSION 16-2(47) 10-3-72 BY RHT MAKE USER INIT WORK RIGHT
01900 VERSION 16-2(46) 9-24-72 BY JRL FIX LIB ENTRIES FOR PROC. STR GAR COL
02000 VERSION 16-2(45) 9-21-72 BY RHT SCREW UP THE COMPIL MACRO
02100 VERSION 16-2(44) 9-21-72 BY JRL ADD SPRPDA TO SGC COMPIL MACRO
02200 VERSION 16-2(43) 9-11-72 BY JRL ADD GINFTB,GDATM TO LOWER WHEN NO GLOB
02300 VERSION 16-2(42) 9-5-72 BY JRL BAD FIX TO SGLKBK PROBLEM
02400 VERSION 16-2(41) 8-21-72 BY RHT PUT IN JRL'S STACSV &STACRS
02500 VERSION 16-2(40) 8-7-72 BY RHT CHANGE INILNK STUFF
02600 VERSION 16-2(39) 8-7-72 BY KVL PRINT MSG BEFORE CANT CONTINUE ANY FURTHER MSG (P24)
02700 VERSION 16-2(38) 7-3-72 BY DCS BUG #IC# ADD NEW MEANING TO NOSHRK(USER)
02800 VERSION 16-2(37) 7-3-72 BY DCS BUG #IB# MAKE DEFAULT SYSTEM STACK SIZE BIGGER
02900 VERSION 16-2(36) 7-2-72 BY JRL HAVE %ALLOC CALL LPINI IF NEEDED
03000 VERSION 16-2(35) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
03100 VERSION 16-2(34) 5-16-72 BY DCS BUG #HI# %ARRSRT TESTS RIGHT BIT FOR STR ARRAY NOW
03200 VERSION 16-2(33) 5-11-72 BY DCS BUG #HE# MODIFY VERSION CHECKING, INSTALL VERSION 16
03300 VERSION 15-6(23-32) 5-3-72 VARIOUS FIXES
03400 VERSION 15-6(14-22) 2-21-72 VARIOUS FIXES
03500 VERSION 15-6(13) 2-19-72 BY RHT THE BRAVE NEW WORLD
03600 VERSION 15-2(12) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
03700 VERSION 15-2(11) 2-2-72 BY DCS BUG #GI# LEAVE SOME SLOP IN REMCHR SO CAT'LL BE MORE EFFICIENT
03800 VERSION 15-2(10) 2-1-72 BY DCS REPLACE (FIXED) %ALLOC BLOCK ACCESSES BY SYMBOLIC HEAD-DEFINED ONES
03900 VERSION 15-2(9) 1-30-72 BY DCS REPLACE %ALLOC -- INITIAL ALLOCATION
04000 VERSION 15-2(8) 1-14-72 BY DCS BUG #GA# SEGMENTS HAVE .SEG EXTENSIONS, NOT .REL
04100 VERSION 15-2(7) 1-3-72 BY DCS BUG #FX# REMOVE NEED FOR COM2, REORGANIZE SEGMENT-GETTING STUFF
04200 VERSION 15-2(6) 12-26-71 BY DCS BUG #FU# REENABLE ACCESS FROM ERR UUO TO FTDEBUGGER
04300 VERSION 15-2(5) 12-24-71 BY DCS BUG #FT# DSPLIN BETTER, TV AS VALID EDITOR
04400 VERSION 15-2(4) 12-22-71 BY DCS BUG #FF# SIXPRT(14-15) TO ERR, IOERR ROUTS
04500 VERSION 15-2(3) 12-22-71 BY DCS BUG #FS# REMOVE SAILRUN, COM2, ASSUME COMPILER
04600 VERSION 15-2(2) 12-2-71 BY DCS ADD VERSION SETUP CODE
04700 VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
04800
04900 ⊗;
00100 SUBTTL Command File Descriptions
00200 LSTON (GOGOL)
00300 COMMENT ⊗
00400
00500 The following command files make runtime routines:
00600
00700 1. RUN
00800 One assembly, get a non-library, non-2d-segment runtime package
00900
01000 RUNTIM=CALLIS(LR)+HEAD+ORDER+GOGOL+STRSER+IOSER+NWORLD+LEPRUN+MESPRO+WRDGET
01100
01200 2. SGMNT
01300 Makes the non-global UPPER.REL and SAILOW.REL, which when
01400 loaded and run and stuff become SAISGn.SEG and SAILOW.REL,
01500 the 2d segment runtime routines
01600
01700 TAILOR=HEAD+FILSPC+TAILOR/NOLO
01800 LOWER=CALLIS+HEAD+LOW+FILSPC+GOGOL/NOLO
01900 TAILOR.REL,UPPER=CALLIS+HEAD+UP.FAI+ORDER+GOGOL+STRSER+IOSER+
02000 NWORLD+LEPRUN+MESPRO+WRDGET
02100
02200 5. GSGMNT
02300 Makes the global model SAILOW AND UPPER, otherwise like
02400 SGMNT
02500
02600 Same, but add GLB after HEAD in all three.
02700
02800 6. SCISS.SAI
02900 This SAIL program, when run, uses the runtime files to
03000 make a LIBSAI.REL file, the SAIL (lower-segment) library
03100 ⊗
00100 SUBTTL Conditional Assembly Switches, Macros
00200 DSCR ** CONDITIONAL ASSEMBLY SWITCHES **
00300 ⊗
00400
00500 STSW(UPPER,0) ;NOT UPPER OR LOWER IF NEITHER SET
00600 STSW(LOWER,0)
00700 STSW(GLOBSW,0) ;ONLY GLOBAL IF SOMEBODY ELSE SAID SO
00800 STSW(SEGS,0)
00900 STSW(RENSW,0) ;RE-ENTRANT LIBRARY (HISEG) IF ON
01000 STSW(LEAPSW,1) ;ASSUME LEAP
01100
01200 DSCR COMPIL(NAM,ENTRIES,EXTERNALS,DESCRIPTION,INTERNALS,HINHB)
01300 CAL MACRO
01400 PAR NAM IS 3 CHAR NAME -- TITLE WILL BE SAINAM
01500 ENTRIES ARE LIST OF ENTRIES CONTAINED IN THIS
01600 LIBRARY ASSEMBLY (INTERNALS IF NOT LIBRARY SETUP)
01700 EXTERNALS (OPTIONAL) ARE EXTERNALS NEEDED FOR THIS ENTRY.
01800 DESCRIPTION IS OPTIONAL, AND IS USED IN THE SUBTTL
01900 IF PRESENT.
02000 INTERNALS (OPTIONAL) DESCRIBE INTERNALS WHICH ARE NEVER ENTRIES.
02100 HINHB (OPTIONAL ANYTHING), IF NON-BLANK, INHIBITS THE HISEG)
02200 DES IF MAKING A LIBRARY, AND IF THIS FILE IS DESIRED
02300 (SEE SCISS PROGRAM), A FILE OF THE NAME SAINAM.FAI
02400 WILL BE MADE CONTAINING ALL THE PROGRAM TEXT FROM THE
02500 COMPIL MACRO TO THE ENDCOM MACRO WHICH SHOULD FOLLOW
02600 THE CODE FOR THIS ENTRY. ENDCOM DOES AN END IF
02700 IN LIBRARY COMPILE MODE.
02800 RES THE MACRO EXPANDS TO PROVIDE A TITLE AND THE
02900 APPROPRIATE ENTRIES AND EXTERNALS FOR THIS ASSEMBLY.
03000 ALSO A SUBTTL CONTAINING THE TITLE AND OPTIONAL
03100 DESCRIPTION IS PROVIDED.
03200 ⊗
03300 DEFINE COMPIL ' (NAM,ENT,EXT,DSCRP,INT,HINHB,DUMMY) <
03400 IFIDN <DUMMY>,<> <
03500 SUBTTL SAI'NAM -- DSCRP
03600
03700 IFE ALWAYS,<
03800 IFDIF <><ENT>,<ENTRY ENT>
03900 TITLE SAI'NAM
04000 REN <
04100 IFIDN <><HINHB>,<HISEG ;LOAD TO UPPER IF POSSIBLE>
04200 >;REN
04300 IFDIF <><EXT>,<EXTERN EXT>
04400 >;IFE ALWAYS
04500 NOLOW <
04600 IFDIF <><INT>,<INTERN INT>
04700 IFN ALWAYS,<
04800 IFDIF <NAM><LOR>,<
04900 IFDIF <><ENT>,<INTERNAL ENT>
05000 >>
05100 >;NOLOW
05200 >;IFIDN <DUMMY>
05300 >
05400
05500 DEFINE COMPXX ' (NAM,ENT,EXT,DSCRP,INT,HINHB)
05600 <COMPIL(<NAM>,<ENT>,<EXT>,<DSCRP>,<INT>,<HINHB>)>
05700
05800 DEFINE ENDCOM (NAM) <
05900 IFE ALWAYS,<
06000 END
06100 >;IFE ALWAYS
06200 >
06300 ; SWITCHES TO CONTROL LIBRARY COMPILATION
06400
06500 IFNDEF ALWAYS,<↓ALWAYS←←1>
06600
06700 IFN ALWAYS,<DEFINE ENTINT (X) <INTERNAL X>>
06800 IFE ALWAYS,<DEFINE ENTINT (X) <ENTRY X>>
06900
00100 SUBTTL Titles, Versions
00200 DSCR TITLES, VERSIONS
00300 ⊗
00400 IFN ALWAYS,<
00500 ; "TITLE UPPER" IS FOUND IN UP.FAI FILE TO MAKE OUTER PROG TITLED
00600 LOW <
00700 TITLE LOWER
00800 >;LOW
00900 NOUP <
01000 NOLOW <
01100 TITLE RUNTIM -- SAIL RUNTIME ROUTINES
01200 >;NOLOW
01300
01400 JOBVER←←137
01500 LOC JOBVER
01600 ;;#HE# DCS 5-11-72 (1-2) MODIFY VERSION STUFF
01700 .VERSION&777777000000 ;CURRENT VERSION NUMBER (LH ONLY)
01800 ;;#HE# (1-2)
01900 RELOC
02000 LOC 124 ;SET UP REENTER ADDRESS
02100 REENT
02200 RELOC
02300 >;NOUP
02400 >;ALWAYS≠0
02500 EXTERNAL JOBHRL
00100 SUBTTL AC Definitions
00200 DSCR AC DEFINITIONS
00300 ⊗
00400
00500 ; AC DEFINITIONS FOR SERVICE AND RUNTIME ROUTINES
00600
00700 ; ALL UUO ROUTS, IOSER COMMENTS
00800 ; CORE ROUTS,
00900 ; STRING GC,
01000 ; ALLOCATION
01100
01200 ↓FF←←0
01300 ↓A←1 ;TEMPS FOR ALLES
01400 ↓B←2 ; (SOMETIMES SAVED)
01500 ↓C←3
01600 ↓D←4
01700 ↓E←5 ↓X←5 ;MORE TEMPS
01800 ↓Q1←6 ↓Y←6
01900 ↓Q2←7 ↓Z←7
02000 ↓Q3←10 ↓Q←10
02100 ↓T←11 ↓CDB←11 ;CHANNEL DATA BLOCK PTR
02200 ↓T1←12 ↓CHNL←12 ;CHNL # FOR IOSER
02300 ↓LPSA←13 ;TEMP, PARAM AC
02400 ↓TEMP←14 ;TEMP ONLY
02500 ↓USER←15 ;→USER TABLE FOR RNTRNT ROUTS
02600 ↓SP←16 ;STRING STACK
02700 ↓P←17 ;SYSTEM STACK
00100 SUBTTL CDB, SIMIO Indices For IOSER, OTHER INDICES
00200
00300 DSCR -- CDB, SIMIO INDICES FOR IOSER
00400 DES The I/O routines obtain their information from the user via a
00500 channel number -- the same kind used by the system. In order to
00600 find byte pointers, counts, file names, etc., the channel number is
00700 used to index into a block of core called a CDB (Channel Data Block).
00800 This CDB is filled with good data during the OPEN operation.
00900 The CDB, and all I/O buffers, are obtained from CORGET.
01000 The CHANS table in the GOGTAB area is a 20 word block containing
01100 pointers to the appropriate CDB's.
01200 Since channel numbers must appear in the AC field of IO instructions,
01300 one must construct IO insts. in impure places to retain re-entrancy.
01400 XCT INDEX,SIMIO executes the appropriate IO instruction with the
01500 channel number from AC CHNL, used by all routines. See SIMIO for
01600 operational details.
01700 ⊗
01800
01900 ; SIMIO INDICES FORMAT OF CDBs
02000
02100 DMODE ←← 0 ↔↓IOSTATUS ←← 0 ;DATA MODE ;RETURN STATUS
02200 DNAME ←← 1 ↔↓IOIN ←← 1 ;DEVICE ;BUFFERED INPUT
02300 BFHED ←← 2 ↔↓IODIN ←← 2 ;HEADER POINTERS ;DUMP INPUT
02400 ↓IOOUT ←← 3 ;BUFMODE OUT.
02500 OBPNT ←← 3 ↔↓IODOUT ←← 4 ;OUTPUT BUF. PTR ;DUMP OUTPUT
02600 OBP ←← 4 ↔↓IOCLOSE ←← 5 ;OUTPUT BYTE PTR ;CLOSE FILE
02700 OCOWNT ←← 5 ↔↓IORELEASE←← 6 ;OUTPUT BYTE CNT ;RELEASE FILE
02800 ONAME ←← 6 ↔↓IOINBUF ←← 7 ;OUTPUT FILE NAM ;INBUF
02900 OBUF ←← 7 ↔↓IOOUTBUF ←←10 ;OUTPUT BUFFER LOC. ;OUTBUF
03000 ↔↓IOSETI ←←11 ;USETI
03100 IBPNT ←←10 ↔↓IOSETO ←←12 ;SAME FOR INPUT ;USETO
03200 IBP ←←11 ↔ ; 13 UNUSED
03300 ICOWNT ←←12 ↔↓IOOPEN ←←14 ;OPEN CHANNEL
03400 INAME ←←13 ↔↓IOLOOKUP ←←15 ;LOOKUP FILE
03500 IBUF ←←14 ↔↓IOENTER ←←16 ;ENTER FILE
03600 ↔↓IORENAME ←←17 ;RENAME FILE
03700
03800 ICOUNT ←←15 ;INPUT DATA COUNT LIMIT ADDRESS
03900 BRCHAR ←←16 ;XWD TTYDEV FLAG, INPUT BREAK CHAR ADDR
04000 TTYDEV ←←16 ;LH -1 IF DEVICE IS A TTY -- USED BY OUT
04100 ENDFL ←←17 ;INPUT END OF FILE FLAG ADDR
04200 ERRTST ←←20 ;USER ERROR BITS SPECIFICATION WORD
04300 PGNNO ←←20 ;PAGE NUMBER FOR DISPLAY FEATURE (IF FEATURE NOT INCLUDED)
04400 NOEXPO <
04500 PGNNO ←←21 ;SAME THING IF IT IS INCLUDED
04600 >;NOEXPO
04700 ↑IOTLEN ←←PGNNO+1 ;LENGTH OF TABLE ENTRY
04800
04900 ↓LUPDL←30 ;LENGTH OF UUO PDL
05000 ↓MINPDS←←=64 ;SMALLEST ALLOWABLE SYSTEM PDL SIZE
05100 ↓DEFPDS←←=192 ;DEFAULT PDL SIZE
00100 SUBTTL Base (Low Segment) Data Descriptions -- Macros, Compil spec
00200
00300 DSCR DATA DESCRIPTIONS, TAILORED FOR TWO SEGMENT OPERATION
00400 ⊗
00500
00600 NOUP <
00700 DEFINE SGLK (ROUT,NAM,INT) <
00800 XX (NAM,ROUT,INT) ;NAME OF STRING DSCRPTR GENERATING ROUTINE
00900 XX (,0,) ;PLACE TO PUT A LINK
01000 LINK %SGROT,.-1 ;WHEREWITHAL TO GENERATE SAID LINK
01100 >
01200 >;NOUP
01300 UP <
01400 DEFINE SGLK (ROUT,NAM) <
01500 XX (NAM,ROUT,)
01600 XX (,0,)
01700 >
01800 >;UP
01900
02000 DEFINE XX (A,B,C,D) <
02100 IFDIF <A><>,<↓ A :> B
02200 IFDIF <C><>,< C A >>>
02300 UP <
02400 III←←140
02500 DEFINE XX (A,B,C,D) <
02600 IFDIF <A><>,<↓ A ← III >
02700 III ←← III + 1
02800 IFDIF <D><>,<III←III+D-1>
02900 >
03000 >;UP
03100
03200
03300 COMPIL(LOR,<SAILOR,.SEG2.>
03400 ,<%UUOLNK,%ALLOC,%SPGC,%STRMRK,%ARRSRT,K.OUT,K.ZERO>
03500 ,<BASE DATA, INITIALIZATION CONTROL>
03600 ,<X11,X22,X33,X44>,INHIBIT)
00100 SUBTTL Base (Low Segment) Data Descriptions - Params, Links, Size specs
00200
00300 ; UNIVERSAL VARIABLES -- BASES OF MAJOR DATA STRUCTURES, GLOBAL FLAGS
00400
00500 XX (GOGTAB,0,INTERNAL) ;→USER TABLE
00600 XX (DATM,0,INTERNAL) ;XWD 3,→DATUM TABLE
00700 XX (LKSTAT,0,INTERNAL) ;STATUS OF GLOBAL LEAP MODEL INTERLOCK (SHOULD BE IN GOGTAB
00800 XX (INFTB,0,INTERNAL) ;XWD 2,→INFOTAB TABLE
00900 XX (.SKIP.,0,INTERNAL) ;RECORD AUX RESULTS OF RUNTIMES
01000 XX (RPGSW,0,INTERNAL) ;SET IF (JOBSA)+1 USED TO START
01100 XX (%RENSW,0,INTERNAL) ;SET IF USER REENTERS TO SPECIFY ALLOC
01200 XX (CONFIG,0,INTERNAL) ;0 FOR RUNTIME, <0 FOR COMPILER
01300 XX (ERRSPC,0,INTERNAL) ;ADDR OF COMPILER'S ERROR AUGMENTOR
01400 XX (RUNNER,0,INTERNAL) ;THE CURRENTLY RUNNING PROCESS(IF HAVE THEM)
01500 XX (INTRPT,0,INTERNAL) ;MASK FOR INTERRUPT POLLING
01600 XX (PROPS,0,INTERNAL) ;BYTE POINTER FOR ACCESSING PROPS(ITEM) ITEM IN 3
01700 XX (NOPOLL,0,INTERNAL) ;≠0 →→ IGNORE CALL TO DDFINT
01800 XX (DEFSSS,0,INTERNAL) ;DEFAULT S-STACK SIZE -- SET BY MAINPR
01900 XX (DEFPSS,0,INTERNAL) ;DEFAULT P-STACK SIZE (FOR PROCESSES) -- DITTO
02000 XX (DEFPRI,0,INTERNAL) ;DEFAULT PRIORITY -- DITTO
02100 XX (DEFQNT,0,INTERNAL) ;DEFAULT QUANTUM -- DITTO
02200 XX (S1PARE,0) ;SPARE LOWER LOCATIONS
02300 XX (S2PARE,0)
02400 XX (S3PARE,0)
02500 XX (S4PARE,0)
02600 XX (S5PARE,0)
02700 GLOB <
02800 XX (GSPARE,<BLOCK 2>,,2)
02900 >;GLOB
03000 NOGLOB <
03100 XX (GDATM,0,INTERNAL) ;DUMMY GLOBAL DATUM TABLE SHOULD ALWAYS BE ZERO
03200 GPROPS←GINFTB←GDATM ;DUMMY GLOBAL INFOTAB DITTO
03300 INTERNAL GINFTB,GPROPS
03400 >;NOGLOB
03500
03600 ; STATIC LINKAGES -- FEATURE PROVIDED BY LOADER
03700 ; THESE ARE THE BASES OF ONE-WAY LINKED LISTS WHICH ALLOW ACCESS
03800 ; TO SELECTED DATA IN ALL LOADED MODULES
03900
04000 XX (STLNK,0,INTERNAL) ;1 ALL STRINGS TIED TOGETHER FOR STRNGC
04100 XX (SPLNEK,0,INTERNAL) ;2 ALL SPACE REQUESTS (PDLS, ETC.)
04200 XX (SETLET,0,INTERNAL) ;3 ALL SET VARIABLES TIED TOGETHER
04300 XX (SGROT,0,INTERNAL) ;4 LIST OF STRNGC SORTER GENERATORS
04400 XX (KTLNK,0,INTERNAL) ;5 ALL COUNTER BLOCKS
04500 XX (INILNK,0,INTERNAL) ; INITIALIZATION ROUTINES (LPINI ONLY NOW)
04600
04700 SYSPHS←←2 ;TWO SYSTEM PHASES
04800 USRPHS←←1 ;TWO USER PHASES (FOR NOW)
04900
05000 ; THESE OPS INFORM THE LOADER OF THE ABOVE BASE LOCATIONS.
05100
05200 NOUP <
05300 LINKEND %STLNK,STLNK
05400 LINKEND %SPLNK,SPLNEK
05500 LINKEND %SETLK,SETLET
05600 LINKEND %SGROT,SGROT
05700 LINKEND %KTLNK,KTLNK
05800 LINKEND %INLNK,INILNK
05900 >;NOUP
06000
06100 ; SOME ROUTINES WHICH GO ON THE SGROT LIST (SEE SGLK)
06200 ;↑SGLKBK
06300 SGLK (%ARRSRT,SGLKBK,INTERNAL);ROUTINE TO COLLECT STRING ARRAYS
06400 SGLK (%STRMRK) ;ROUTINE TO COLLECT STRING VARIABLES
06500 SGLK (%SPGC) ;ROUTINE TO COLLECT STRING STACK
06600
06700
06800 ;HERE IS THE LIST OF DEFAULT SPACE ALLOCATION ENTRIES
06900 XX (%SPL,<BLOCK $SPREQ-2>,INTERNAL,$SPREQ-2);DUMMY FIXED ADDR STUFF
07000 XX (%STDLST,<BLOCK 2>,INTERNAL,2) ;BASE OF BUILT-IN REQUESTS
07100 XX (,<XWD WNTPDP!MINSZ!USRTB,DEFPDS>) ;SYSTEM_PDL (SPECIAL, SEE BELOW)
07200 XX (,<XWD [ASCIZ /SYSTEM_PDL/],PDL>)
07300 XX (,<XWD WNTPDP!USRTB!MINSZ,50>) ;STRING STACK
07400 XX (,<XWD [ASCIZ /STRING_PDL/],SPDL>)
07500 XX (,<XWD WNTADR!WNTEND!USRTB!MINSZ,2000>);STRING_SPACE
07600 XX (,<XWD [ASCIZ /STRING_SPACE/],ST>)
07700 XX (,0) ;THAT'S ALL
07800 ; LINK %SPLNK,%SPL ;%ALLOC DOES THIS EXPLICITLY SO THIS
07900 ;BLOCK WILL BE FIRST
08000
08100 ;SOME RANDOM GLOBALLY USEFUL THINGS, WHICH UNFORTUNATELY HAVE TO
08200 ;BE IN FIXED LOCATIONS (FOR THE RUNTIMES TO FIND)
08300
08400 XX (ALLPDP,<IOWD 20,ALLPDL>,INTERNAL);USED FOR A WHILE DURING ALLOC
08500 XX (ALLPDL,<BLOCK 20>,INTERNAL,20) ;AND IN PROCESS TERMINATION
08600 XX (%ALLCHR,0,INTERNAL)
08700 XX (%OCTRET,0,INTERNAL)
08800 XX (%ERGO,0,INTERNAL) ;ON IF LF TYPED TO ERR. GUY
08900 XX (%RECOV,0,INTERNAL) ;ON IF RECOVERY FROM ERR. IS POSSIBLE
09000 XX (DPYSW,0,INTERNAL) ;ON IF CONSOLE IS DPY
09100 XX (%UACS,<BLOCK 20>,INTERNAL,20) ;UUOCON ACS
09200 XX (%UPDL,<BLOCK LUPDL+1>,INTERNAL,LUPDL+1) ;UUOCON PDL
09300 NOEXPO <
09400 XX (PGDS,<PGDS0>,INTERNAL) ;PIECE OF GLASS FOR LINE BREAK ON INPUT
09500 XX (,7,)
09600 XX (PGDS0,0,)
09700 XX (,<AIVECT (300,200)>,)
09800 XX (,<ASCID /PAGE/>,)
09900 XX (,<ASCID / />,)
10000 XX (,<ASCID /LINE />,)
10100 XX (,<ASCID / />,)
10200 XX (,<DPYJMP PGDS0>,)
10300 >;NOEXPO
10400
10500 ;SOME WONDERFULLY USEFUL CONSTANTS
10600
10700 XX (X11,<XWD 1,1>,INTERNAL)
10800 XX (X22,<XWD 2,2>,INTERNAL)
10900 XX (X33,<XWD 3,3>,INTERNAL)
11000 XX (X44,<XWD 4,4>,INTERNAL)
11100
11200 ;SINCE UUO TRIGGERING IS NON-RE-ENTRANT, THIS IS THE PLACE WHERE IT HAPPENS
11300
11400 XX (UUO0,0,INTERNAL) ;JSR RETURN STORED HERE
11500 ↓UUCOR←UUO0
11600 NOUP <
11700 JRST %UUOLNK ;GO HANDLE UUO
11800 >;NOUP
11900
12000 LOW <
12100 EXTERNAL LPINI
12200 LPLK: 0
12300 LPINI
12400 0
12500 LINK %INLNK,LPLK
12600 >;LOW
12700
12800 EXPO <
12900 XX (PPMAX,<BLOCK 3>,INTERNAL,3) ;FOR SCREWY EDITOR LINKAGE
13000 >;EXPO
13100
00100 SUBTTL Initialization Routines, Data
00200
00300 COMMENT ⊗ The Run-Time I/O handling routines are re-entrant. This
00400 means that any modifiable words or parameters particular to a given
00500 user must come from the user's core image. The pointer to this area
00600 will be found in GOGTAB in the lower segment. The I/O routines use
00700 some of the AC'S in standard ways, described above with AC definitions.
00800 ⊗
00900
01000 DSCR SAILOR -- ALLOCATION AND INITIALIZATION ROUTINES
01100 CAL JSR
01200 DES
01300
01400 Part of this is not yet reentrant. In particular,
01500 it is called by a JSR SAILOR
01600 The functions of this routine are:
01700
01800 1. Get a second segment, if this is a SAISEG-program
01900 2. Process space requests, allow user-override if REENTER used
02000 to start.
02100 3. Use %ALLOC to allocate requested regions.
02200 4. Clear Kounters
02300 5. Change starting and re-entry addresses,
02400 6. PUSHJ to user program
02500 7. Record Kounters, RESET and quit.
02600 ⊗
00100 SUBTTL Sailor, Reent -- Allocation, Main Program Control
00200
00300 NOUP <
00400 ;SAIL job calls SAILOR first time, with RPGSW set up already
00500
00600 INTERNAL SAILOR
00700 ↑SAILOR: 0 ;JSR to SAILOR
00800 JRST FRSTRT ;GET A SEGMENT, START UP
00900
01000 ; REENTER to manually change allocation, and to flush REQUIREd segments
01100
01200 ↑REENT: SETOM %RENSW ;RE-ENTER -- ASK FOR NEW ALLOC
01300
01400 ;SAIL STARTS HERE WHEN USER TYPES S<T<A<R<T>>>> AGAIN
01500
01600 ↑RESTRT:TDZA TEMP,TEMP ;ESTABLISH OPERATING MODE
01700 MOVNI TEMP,1 ;RPG MODE
01800 MOVEM TEMP,RPGSW ;RECORD IT
01900 FRSTRT: JSP P,.SEG2. ;GET SECOND SEGMENT
02000
02100 STRT: CALLI
02200 SETZM GOGTAB ;FORCE CORSER RE-INITIALIZATION
02300 SETNIT ;GET TEMP STACK, IF NECESSARY
02400 JSP 16,%ALLOC ;ALLOCATE AREAS
02500 MOVEI A,RESTRT ;CHANGE JOBSA AND JOBREN
02600 HRRM A,JOBSA ;"S" USES OLD ALLOCATION
02700 MOVEI A,REENT ;"REE" ASKS QUESTIONS AGAIN
02800 MOVEM A,JOBREN
02900 PUSHJ P,K.ZERO ;ZERO OUT THE COUNTERS
03000 PUSHJ P,INILST ;GO DO ALL OTHER INITIALIZATIONS
03100 PUSHJ P,@SAILOR ;CALL USER PROGRAM
03200 PUSHJ P,K.OUT ;WRITE OUT THE COUNTERS
03300 TERPRI <END OF SAIL EXECUTION>
03400 CALL6 (0,RESET) ;CLEAR THE I/O WORLD
03500 CALL6 (1,EXIT) ;QUIT QUIETLY
03600
03700 INILST:
03800 SKIPN TEMP,INILNK
03900 POPJ P,
04000 MOVE USER,GOGTAB ;JUST TO BE SURE
04100 SKIPA A,[XWD -SYSPHS,0] ;XWD #SYS PHASES,0
04200 DOPHS: HRRZ TEMP,INILNK ;LIST OF THEM
04300 NXLNK:
04400 PUSH P,TEMP ;SAVE LINK
04500 NXIN: ADDI TEMP,1 ;LOOK AT NNEXT ENTRY
04600 SKIPN B,(TEMP) ;END OF LINK LIST
04700 JRST NXIN.1 ;YES
04800 HLRZ C,B ;PHASE NUMBER OF THIS
04900 CAIE C,(A) ;THIS PHASE
05000 JRST NXIN ;NO
05100 PUSH P,A
05200 PUSH P,TEMP
05300 PUSH P,USER
05400 PUSHJ P,(B)
05500 POP P,USER
05600 POP P,TEMP
05700 POP P,A
05800 JRST NXIN ;GO DO NEXT IN THIS
05900 NXIN.1: POP P,TEMP
06000 HRRZ TEMP,(TEMP)
06100 JUMPN TEMP,NXLNK
06200 NXPHS: AOBJN A,DOPHS ;GO ON TO NEXT PHASE
06300 POPJ P, ;
06400
06500 INTERNAL .UINIT
06600 .UINIT: MOVE A,[XWD -USRPHS,400000] ;DO USER PHASES
06700 ;; #KV# MAKE SURE LINK NON-NULL
06800 SKIPN INILNK
06900 POPJ P,
07000 ;; #KV#
07100 JRST DOPHS
00100 SUBTTL .SEG2. -- Get a second segment
00200
00300 COMMENT ⊗ Initialize the second segment, if there is none and if desired.
00400 This occurs when the program is first started. This is a dummy routine
00500 if not a SAISEG-program
00600 ⊗
00700
00800 INTERNAL .SEG2.
00900 .SEG2.:
01000 LOW <
01100 IFE SEG3SW,<
01200 SKIPE JOBHRL ;IS THERE A SEGMENT?
01300 >;IFE SEG3SW
01400 IFN SEG3SW,<
01500 OPDEF RPACS [104000000057]
01600 HASPAGE←←10000
01700
01800 MOVE 1,[400000000650]
01900 RPACS
02000 TLNE 2,HASPAGE ;IS THERE A SEGMENT?
02100 >;SEG3SW
02200 >;LOW
02300 JRST (P) ; YES, GO AHEAD (OR ALWAYS, IF NOLOW)
02400 >;NOUP
02500
02600 LOW <
02700
02800 COMMENT ⊗ Now, if global model, get segment specifications from space blocks
02900 of compiled programs (via REQUIRE verbs in source code).
03000 Segment name business is ignored in EXPO version, since segment and file
03100 names are always equivalent (philosophical differences).
03200 ⊗
03300
03400 SEGTR: ;TRY AGAIN
03500 GLOB <
03600
03700 SKIPN %RENSW ;IS LINK-TABLE AND/OR PREVIOUSLY COLLECTED
03800 ; INFORMATION INVALID??
03900 JRST SEG3 ;NO
04000 FOR II⊂(SEGDEV,SEGFIL,SEGPPN,NMSAV) <
04100 SETZM II
04200 >
04300 JRST ASKEM ;CLEAR ALL NON-USER SPECIFIED INFO
04400
04500 SEG3: SKIPN B,SPLNEK ;A SPACE BLOCK AROUND??
04600 JRST ASKEM ; NO
04700 GSGLP: SKIPE A,$SGD(B) ;DEVICE REQUEST
04800 MOVEM A,SEGDEV
04900 SKIPE TEMP,$SGF(B) ;FILE NAME FOR UPPER SEGMENT
05000 MOVEM TEMP,SEGFIL
05100 SKIPE TEMP,$SGPP(B) ;PPN FOR SAME
05200 MOVEM TEMP,SEGPPN
05300 SKIPE TEMP,$SGNM(B) ;SEGMENT NAME (UNUSED IN EXPO VERSION)
05400 MOVEM TEMP,NMSAV
05500 SKIPE B,(B) ;GO DOWN LINKED LIST
05600 JRST GSGLP ; UNTIL EMPTY
05700 >;GLOB
00100
00200 COMMENT ⊗ If not enough information was supplied (global model only),
00300 ask questions of user to obtain file names, etc. Also (NOEXPO only),
00400 try to ATTSEG to a segment of the desired name. In the EXPO version,
00500 all this is combined in the GETSEG below.
00600 ⊗
00700 NOEXPO < ;SEGMENT NAME NOT USEFUL TO EXPO SYSTEM
00800 GLOB <
00900 SKIPE A,NMSAV ;DID WE GET A SEGMENT?
01000 JRST GOTEM ; YES, TRY TO LINK TO IT
01100
01200 ASKEM: TERPRI <SEGMENT LOGICAL NAME?>
01300 JSR GGNAM ;GET A SEGMENT NAME.
01400 GOTEM: MOVEM A,NMSAV
01500 >;GLOB
01600 NOGLOB <
01700 MOVE A,[FILXXX] ;TRY TO FIND IT.
01800 >;NOGLOB
01900 CALLI A,400016 ;ATTSEG.
02000 SKIPA ;NO LUCK
02100 JRST (P) ;OK, DONE
02200 HRRZ B,A ;GET FAILURE CODE.
02300 CAIE B,1 ;AMBIGUITY?
02400 JRST GETSE ;NO -- GET THE SEGMENT.
02500 HLRZS A
02600 CALLI A,400016 ;ATTSEG.
02700 JSP A,ERSEG
02800 JRST (P) ;OK, GOT IT
02900 >;NOEXPO
03000 EXPO <
03100 ASKEM: ;MISPLACED LABEL
03200 >;EXPO
03300 GETSE: CALLI
03400 GLOB <
03500 SKIPE A,SEGFIL ;WAS ONE "REQUIRE"D?
03600 JRST THSFL ; YES, USE IT
03700 TERPRI <SEGMENT FILE NAME?>
03800 MOVE A,[FILXXX] ;DEFAULT
03900 JSR GGNAM
04000 THSFL: MOVEM A,SEGFIL ;NAME OF SEGMENT.
04100 THSFL1: SKIPE A,SEGDEV ;WAS A DEVICE REQUESTED?
04200 JRST THSDV ; YES
04300 TERPRI <DEVICE?>
04400 MOVE A,[SGDEVC] ;DEFAULT DEVICE
04500 JSR GGNAM
04600 MOVEM A,SEGDEV
04700 CAMN A,['DSK '] ;ASK FOR PPN IF DISK
04800 SKIPE SEGPPN ;AND PPN=0
04900 JRST THSDV ;DON'T ASK, ALREADY THERE
05000 TERPRI <PPN?>
05100 MOVE A,[SGPPNN] ;DEFAULT PPN
05200 JSR GGNAM
05300 MOVEM A,SEGPPN
05400 JRST THSFL1 ;NOW HAVE A DEVICE
05500 THSDV: MOVEM A,INTT
05600 MOVE A,[XWD SEGDEV,DEVSEG] ;MOVE LOOKUP SPEC IN
05700 BLT A,SEGNAM+3
05800 >;GLOB
05900 NOGLOB <
06000 SETZM SEGNAM+2
06100 MOVE TEMP,[SGPPNN]
06200 MOVEM TEMP,SEGNAM+3 ;SET UP PPN
06300 HLLZS SEGNAM+1
06400 >;NOGLOB
00100
00200 COMMENT ⊗ Now work is nearly done in EXPO system, but all sorts of hair
00300 remains otherwise. In either case, now get segment in, get it into 2d
00400 segment, name it right
00500
00600 ⊗
00700 NOEXPO <
00800 INIT 1,17
00900 INTT: SGDEVC ;GO GET THE RAW SEGMENT
01000 0
01100 JSP A,ERSEG
01200 LOOKUP 1,SEGNAM
01300 JSP A,ERSEG
01400 MOVS A,SEGNAM+3 ;WORD COUNT
01500 HRLM A,LIOD ;WORD COUNT FOR DUMP MODE.
01600 MOVNS A
01700 HRRO D,JOBREL ;FOR LATER
01800 HRRM D,LIOD ;PLACE TO START DUMP MODE INPUT.
01900 ADD A,JOBREL ;TO GET THE AMOUNT OF CORE NEEDED.
02000 CALLI A,11 ;CORE UUO ----
02100 JSP A,ERSEG
02200 LOP22: INPUT 1,[LIOD: IOWD 200,%UPDL
02300 0]
02400 GLOB <
02500 TLZ D,-1 ;NO, MAKE IT WRITEABLE IF GLOBAL MODEL.
02600 >;GLOB
02700 IFN NOPROT,<
02800 TLZ D,-1 ;MAKE WRITEABLE IF REQUESTED TO
02900 >;NOPROT≠0
03000 CALL D,[SIXBIT/REMAP/] ;
03100 JSP A,ERSEG
03200 NOGLOB <
03300 MOVE A,[FILXXX]
03400 >;NOGLOB
03500 GLOB <
03600 MOVE A,NMSAV
03700 >;GLOB
03800 CALLI A,400036 ;SETNM2
03900 JRST [MOVEI A,0
04000 CALLI A,400015 ;CORE2
04100 JSP A,ERSEG
04200 GLOB <
04300 SETOM %RENSW ;FORCE TTY RITUAL
04400 >;GLOB
04500 JRST SEGTR] ;TRY AGAIN.
04600 CALLI
04700 >;NOEXPO
04800
04900 EXPO <
04905 IFE SEG3SW,<
05000 SETZM SEGNAM+4 ;CLEAR LAST TWO WORDS OF GETSEG BLOCK
05100 SETZM SEGNAM+5
05200 MOVEI A,DEVSEG ;GET READY
05300 MOVEM P,SAVPP
05400 CALL A,[SIXBIT /GETSEG/] ;GET THE SEGMENT
05500 JSP A,ERSEG ; COULDN'T
05600 MOVE P,SAVPP
05700 ; NO WAY TO RENAME 2D SEGMENT, SO DON'T WORRY ABOUT IT
05705 >;IFE SEG3SW
05710 IFN SEG3SW,<
05712 OPDEF GTJFN [104000000020]
05714 OPDEF GET [104000000200]
05715 ;TENEX-ONLY CODE FOR XEROX -- GET SEGMENT WITHOUT THE EMULATOR
05720 MOVSI 1,100001 ;OLD FILE, SHORT CALL
05725 HRROI 2,[ASCIZ/<SAIL>SAISG5.SAV/]
05730 GTJFN
05735 JSP A,ERSEG ;ERROR RETURN
05740 HRLI 1,400000 ;THIS FORK (JFN IN RT HALF)
05745 GET
05755 >;IFN SEG3SW
05800 >;EXPO
05900
06000 JRST (P) ;RETURN
06100 >;LOW
00100
00200 EXPO <
00300 NOUP <
00400 INTERNAL TYPER.,OVPCWD,ERRMSG
00500 ;THESE ARE BECUSE OF LIB40 CHANGES
00600 ; MADE CAPRICIOUSLY BY DEC
00700 TYPER.:
00800 ERRMSG:
00900 OVPCWD: JFCL
01000 ERR <SOME FORTRAN ROUTINE HAS SEEN FIT TO COMPLAIN
01100 ABOUT YOUR STYLE. COMPLAIN TO DEC THAT THEIR ERROR MESSAGE
01200 PROCEDURE IS NOT SUFFICIENTLY GENERAL TO ALLOW GRACEFUL INTERFACE
01300 WITH SAIL.>
01400 >;NOUP
01500 >;EXPO
00100 SUBTTL Segment-Fetching Data
00200
00300 LOW <
00400
00500 NMSAV: 0 ;SAVE LOGICAL SEGMENT NAME HERE
00600 SEGDEV: 0 ;SAVE UPPER SEGMENT DEVICE NAME HERE
00700 SEGFIL: 0 ;SAVE UPPER SEGMENT FILE NAME HERE
00800 NOEXPO <
00900 SIXBIT /SEG/ ;ALWAYS
01000 >;NOEXPO
01100 EXPO <
01200 SIXBIT /SHR/ ;DIFFERENT STROKES FOR ....
01300 >;EXPO
01400 0
01500 SEGPPN: 0 ;SAVE UPPER SEGMENT PPN HERE
01600
01700 DEVSEG: SGDEVC ;USED ONLY BY EXPO'S GETSEG
01800 SEGNAM: FILXXX
01900 NOEXPO <
02000 SIXBIT/SEG/
02100 >;NOEXPO
02200 EXPO <
02300 SIXBIT /SHR/
02400 >;EXPO
02500 0
02600 SGPPNN ;SPECIFIED PPN DEFAULT
02700 EXPO <
02800 0 ↔0 ;SIX WORD BLOCK FOR GETSEG
02900 SAVPP: 0 ;P SAVED HERE OVER GETSEG
03000 >;EXPO
03100 ERSEG: TERPRI <SAIL SEGMENT LOADING ERROR>
03200 GLOB<
03300 SETOM %RENSW ;FORCE TTY RITUAL
03400 >;GLOB
03500
03600 CALLI 12
03700
03800 GLOB <
03900 GGNAM: 0
04000 TTCALL 4,C ;INCHWL.
04100 CAIE C,15 ;IF NOTHING SPECIFIED,
04200 MOVEI A,0 ; USE THE DEFAULT
04300 SKIPA B,[POINT 6,A]
04400 GGGO: TTCALL C ;GET CHAR
04500 CAIN C,15
04600 JRST [TTCALL C ↔ JRST @GGNAM] ;RETURN ON CR.
04700 CAILE C,140
04800 SUBI C,40 ;CONVERT LOWER CASE.
04900 SUBI C,40 ; → SIXBIT
05000 IDPB C,B ;SAVE IT.
05100 JRST GGGO
05200 >;GLOB
05300 >;LOW
05400 ENDCOM(LOR)
05500 LOW <
05600 END
05700 >;LOW
05800 COMPIL(LUP,<%UUOLNK,%ALLOC,SAVE,RESTR,STACSV,STACRS,INSET>
05900 ,<CORGET,STCLER,%RECOV,%UACS,GOGTAB,%UPDL,CONFIG,%ALLCHR>
06000 ,<INITIALIZATION ROUTINES, UUO HANDLER, UTILITY ROUTINES>)
06100 IFE ALWAYS,<
06200 INTERNAL %ALLOC
06300 ; MORE EXTERNALS
06400 EXTERNAL ALLPDP,ERRSPC,SETLET,DPYSW,INILNK
06500 EXTERNAL %ERGO,SPLNEK,UUO0,%OCTRET
06600 EXTERNAL X11,X22,X44,CORINC,%STDLS,%RENSW,%SPL,KTLNK
06700 >;IFE ALWAYS
00100
00200 NOLOW < ;PUT IN UPPER SEGMENT AND ALL THAT FOLLOWS....
00300 UP <
00400
00500 ;IF YOU CHANGE ANYTHING ABOVE THIS POINT, YOU WILL
00600 ;HAVE TO RELOAD. THIS IS THE UPPER SEGMENT DISPATCH TABLE FOR
00700 ;INTERNAL SYMBOLS.
00800
00900 USE DSPCH ;A PC FOR VECTOR JRSTS
01000 USE
01100 BLOCK =200 ;SPACE FOR THE JRSTS.
01200 >;UP
01300
00100 SUBTTL %ALLOC -- Main Allocation Routine
00200
00300 DSCR %ALLOC
00400 CAL JSP 16,%ALLOC
00500 DES Processes space reqests, allocates the storage for stacks,
00600 string space, etc. Sets certain universal environmental variables
00700
00800 The SPLNEK list, created by the LOADER from compiled requests, contains
00900 REQUEST blocks. Space requests begin at location $SPREQ within each
01000 block. The entries consist of two-word entries, viz:
01100
01200 -----------------------------
01300 →- SPLNEK ptr -→ | | →next block | --→
01400 -----------------------------
01500 | |
01600 | fixed LEAP allocation |
01700 | data |
01800 | |
01900 | ... |
02000 -----------------------------
02100 $SPREQ: |OP1 |INDX | SIZe request |
02200 |- - - - - - - - - - - - - - -|
02300 | TEXt addr | RESult ADdRess| (if ¬STDSPC --
02400 ----------------------------- see below)
02500 |OP2 ... | etc. |
02600 -----------------------------
02700 | ... more ops ... |
02800 -----------------------------
02900 | 0 terminates |
03000 -----------------------------
03100
03200 OP is a 12-bit field (0:11), whose bits are interpreted as:
03300 0 STDSPC if 1, get TEX,RESADR spec from standard entry
03400 indexed by INDX field -- this is only a 1-word wntry.
03500 1 WNTADR requests that the address of the allocated core be
03600 returned in the specified RESADR field. RESADR is
03700 then incremented.
03800 2 WNTEND requests that the address of the first word not in the
03900 allocated area be placed in RESADR field. RESADR bumped.
04000 3 WNTPDP requests that a PDP computed from address and length be
04100 returned in like manner.
04200 4 USRTB indicates that the RESADRs are indices into the user
04300 table -- (GOGTAB) should be added before use.
04400 5 MINSZ indicates that the size specified here should be REPLACED
04500 by the first subsequent non-zero request (not ADDED).
04600 Default value for this area -- anything overrides.
04700
04800 INDX is a 6-bit field (12:17) used if STDSPC to cause the address to be
04900 obtained from a spec (with its own OP and addr words) built into GOGOL.
05000 This allows push-down list, string space, etc., sizes to be requested by
05100 object modules without knowing the locations of their descriptors.
05200 The indices represent:
05300 1 SYSPD System push-down list (P)
05400 2 SYSSPD String push-down list (SP)
05500 3 STRSP String space size.
05600
05700 SIZ replaces any previous request with MINSZ on. Otherwise, its value is
05800 added to an accumulated size for this address. The final result will
05900 specify the size of the area.
06000 SIZ<0 causes current entry to be disregarded.
06100
06200 TEX is the address of an ASCIZ string describing the use of the area.
06300 It is used when the user REENTERs to ask him how much space he wants.
06400 A non-zero value means that no overriding is possible for this area.
06500
06600 These requests are accumulated on the stack in two-word entries as:
06700 -----------------------------
06800 $SPREQ: |OP1 |INDX | RESult ADdRess|
06900 |- - - - - - - - - - - - - - -|
07000 | TEXt addr | accum size |
07100 -----------------------------
07200 Inconsistencies in request bits are not likely to be detected.
07300
07400 %ALLOC first processes the entire list, collecting cumulative information
07500 about each RESADR requested, summing the size requests (with mods as
07600 described for MINSZ above). Then it allocates space for each requested
07700 area, allowing the user to override each if he REENTERed, and if there
07800 is TEXt for that area. It finishes by performing some useful but
07900 uninteresting bookkeeping.
08000 ⊗
00100
00200 ; Get a Stack to hold requests in
00300
00400 HERE (%ALLOC)
00500 MOVEI C,MINPDS ;ABOUT 64 WORDS
00600 PUSHJ P,CORGET ;THIS USUALLY INITS THE USER TABLE
00700 ERR <NO CORE FOR ALLOCATION>
00800 PUSHJ P,PDPMAK ;A PUSH-DOWN POINTER
00900 MOVE P,B ;DITCH THE ALLOC PDL
01000 MOVEM B,PDL(USER) ;STORE TEMPORARILY
01100 PUSH P,16 ;THE RETURN ADDRESS
01200 ADD P,X22 ;ONE DUMMY ENTRY TO TERMINATE
01300 SETZM -1(P) ;0 TERMINATES IT
01400
01500 ; Loop to search the space request blocks
01600 ; Until further notice:
01700 ; T is →next allocation block.
01800 ; T1 is →next entry specification
01900 ; Q1 is modified T1 -- accounts for STDSPC specifications
02000 ; Q2 is incoming OP-size word
02100 ; A is →next candidate stack list element
02200 ; Q3 and TEMP used to do RESADR search in already-requested stack list
02300
02400
02500 MOVE T,SPLNEK ;LIST OF BLOCKS
02600 MOVEM T,%SPL ;LINK BUILT-IN BLOCK EXPLICITLY
02700 MOVEI T,%SPL ;ALLOCATE IT FIRST
02800 %AL1: MOVEI T1,$SPREQ(T) ;→FIRST REQUEST
02900 %AL2: SKIPN Q2,(T1) ;OP WORD
03000 JRST NXTELT ;NO MORE THIS BLOCK
03100 MOVE Q1,T1 ;SAVE ADDRESS OF REQUEST
03200 TLNN Q2,STDSPC ;A BUILT-IN RESADR/TEXT?
03300 AOJA T1,DRCT ; NO, GET IT HERE
03400
03500 ; T1 incremented because 2-word entry -- Q1 still → 1st word
03600 ; Here, there is only a 1-word entry -- the actual RESADR spec
03700 ; found by indexing into table.
03800
03900 LDB Q1,[POINT 6,Q2,17] ;THE INDEX
04000 LSH Q1,1 ;2-WORD ENTRIES ALL
04100 ADDI Q1,%STDLST ;HERE'S WHERE THEY LIVE
04200 HLL Q2,(Q1) ;USE STANDARD BITS FROM HERE ON
04300 TLZ Q2,MINSZ ;NEVER USED FOR MIN WHEN BY INDEX
04400
04500 ; Now find the corresponding entry in the accumulated stack entries
04600 ; or add a new entry
04700
04800 DRCT: HRRZ Q3,1(Q1) ;ADDRESS OF RESULT
04900 TLZE Q2,USRTB ;RESULT IN THE USER TABLE?
05000 ADD Q3,GOGTAB ;YES
05100 MOVEI A,-1(P) ;FOR SEARCH DOWN STACK
05200 JRST %AL4 ;GO SEARCH
05300
05400 %AL3: CAIN Q3,(TEMP) ;SAME ADDR?
05500 JRST %AL5 ;YES, UPDATE
05600 SUBI A,2 ;BACK UP ONE
05700 %AL4: SKIPE TEMP,(A) ;NEXT SAVED OP WORD
05800 JRST %AL3 ;TRY THIS ONE
05900
06000 ; First occurrence of this address, make a place for it
06100
06200 MOVEI A,1(P) ;BACK TO THE TOP
06300 ADD P,X22 ;NEW ENTRY
06400 SETZM (A)
06500 SETZM 1(A) ;VIRGIN ENTRY
06600
06700 COMMENT ⊗
06800 NMIN means MINSZ on in new spec, OMIN means it's on in stack spec
06900 NSIZ mean that new size≠0, OSIZ etc. -- then
07000 NMIN∧¬OSIZ ⊃⊃ OSIZ←NSIZ, OMIN←TRUE
07100 NMIN∧ OSIZ ⊃⊃ no change
07200
07300 ¬NMIN∧NSIZ∧OMIN ⊃⊃ OSIZ←NSIZ, OMIN←FALSE
07400 ¬NMIN∧¬NSIZ∧OMIN ⊃⊃ no change
07500 ¬NMIN∧¬OMIN ⊃⊃ OSIZ←NSIZ+OSIZ, OMIN←FALSE
07600
07700 In the sequel,
07800 A→current stack entry, T,T1,Q1 unchanged,
07900 Q2 is NEWSIZ, will be accum SIZ and TEXt addr.
08000 Q3 is NEWBITS,,RESADR, will be accumulated same.
08100 TEMP will be old TEX,,SIZ word, LPSA old BITS,,ADR
08200 ⊗
08300
08400 %AL5: HLL Q3,Q2 ;NEW BITS,,RESADR
08500 HRRES Q2 ;NEW SIZE
08600 MOVE TEMP,1(A) ;OLD TEX,,SIZ
08700 MOVE LPSA,(A) ;OLD BITS,,ADR
08800 JUMPL Q2,AOJBAK ;NO ACTION ON NEGATIVE SIZE
08900 TLNE Q3,MINSZ ;BEGIN THE HAIRY CASE STUDY
09000 JRST INMIN ;MIN ON IN NEW
09100
09200 ; ¬NMIN
09300 TLZN LPSA,MINSZ ;¬NMIN, OMIN? -- OMIN←FALSE
09400 JRST ADDIT ;¬NMIN∧¬OMIN, ADD
09500 JUMPN Q2,%AL6 ;¬NMIN∧ OMIN, NSIZ?
09600 TLOA Q3,MINSZ ;¬NMIN∧ OMIN∧¬NSIZ, NMIN←TRUE, NSIZ+OSIZ=OSIZ
09700 %AL6: HLLZS TEMP ;¬NMIN∧OMIN∧NSIZ, OSIZ←FALSE,NSIZ+OSIZ=NSIZ,NMIN←FALSE
09800 JRST ADDIT ;¬NMIN∧ OMIN, EITHER NSIZ OR OSIZ
09900
10000 ; NMIN
10100 INMIN: TRNE TEMP,-1 ;OSIZ?
10200 TLZA Q3,MINSZ ;NMIN∧OSIZ, OSIZ unchg, NMIN←FALSE
10300 TLZA LPSA,MINSZ ;NMIN∧¬OSIZ, OSIZ←NSIZ, NMIN←TRUE
10400 MOVEI Q2,0 ;NMIN∧OSIZ again, OSIZ unchg over add
10500
10600 ADDIT: OR Q3,LPSA ;COLLECT BITS
10700 ADD Q2,TEMP ;AND SIZE
10800 TLNN Q2,-1 ;ANY TEXT ADDR?
10900 HLL Q2,1(Q1) ;NO, GET FROM OLD IF ANY
11000 MOVEM Q3,(A) ;PUT NEW AWAY
11100 MOVEM Q2,1(A)
11200 AOJBAK: AOJA T1,%AL2 ;NEXT ELEMENT THIS BLOCK
11300
11400 NXTELT: SKIPN T,(T) ;NEXT BLOCK IN ALLOC LIST?
11500 JRST NOELT ;NO MORE.
11600 LEP <
11700 SKIPL $ITNO(T) ;LEAP REQUESTED?
11800 JRST %AL1 ;NO.
11900 MOVE B,GOGTAB ;WILL PLAY WITH USER TABLE
12000 SETOM HASMSK(B) ;SOMEONE WANTS LEAP.
12100 >;LEP
12200 JRST %AL1 ;CONTINUE DOWN ALLOC BLOCKS.
12300 NOELT:
00100
00200 ; SINCE SYSTEM_PDL ALREADY ALLOCATED AND IN USE, INCREMENT IT IF THE
00300 ; REQUEST EXCEEDS THE DEFAULT
00400 MOVE TEMP,PDL(USER)
00500 PUSH P,4(TEMP)
00600 PUSH P,5(TEMP) ;MAKE SURE P-REQUEST ON TOP
00700 SETZM 4(TEMP) ;AND THAT IT DOESN'T HAPPEN TWICE
00800
00900 ; NOW ALLOCATE THE SPACES, GET OVERRIDES
01000 SETZM %ALLCHR ;NO QUESTIONS YET
01100 SKIPN %RENSW ;WAS THERE A REENTER?
01200 JRST NONTR ; NO
01300 TERPRI
01400 PRINT <ALLOC? >
01500 TTCALL 0,B ;ASK LEADING QUESTION AND GET ANSWER
01600 TERPRI
01700 CAIN B,"Y" ;YES?
01800 SETOM %ALLCHR ;YES
01900 CAIN B,"N" ;NO, BUT LET ME SEE IT?
02000 AOS %ALLCHR ;RIGHT
02100 SETZM %OCTRET ;WHEN ON, NO MORE ASKING
02200 NONTR:
02300 ALOC: SKIPN T,-1(P) ;WERE THERE ANY ENTRIES?
02400 JRST DONEE ; MAYBE, BUT NONE LEFT
02500 MOVS A,(P) ;SIZE, TEXT
02600 TRNE A,-1
02700 SKIPL %ALLCHR ;IF TEXT ADDR AND WANTS TO DO IT,
02800 JRST NOASK ; MUST ASK QUESTIONS
02900
03000 OUTSTR (A) ;PRINT IT
03100 PRINT <= >
03200 PUSHJ P,DECIN
03300 HRL A,C ;REPLACE REQUESTED SIZE BY OVERRIDE
03400 NOASK: HLRZ C,A ;IN CASE NOBODY ELSE DID
03500 JUMPE C,PRIN ;DON'T ALLOCATE 0 AREAS
03600 HRRZ TEMP,T ;DEST ADDR
03700 CAIE TEMP,PDL(USER) ;THE ONE AND ONLY?
03800 JRST NOEXP ; NO
03900
04000 ;THIS IS THE SYSTEM_PDL REQUEST -- IT MUST OVERLAY THE CURRENTLY
04100 ; ALLOCATED STACK
04200 HRRZ B,PDL(USER) ;GET PREV INITIAL CORGET ADDRESS
04300 CAIGE C,MINPDS ;MUST BE BIGGER
04400 MOVEI C,MINPDS ; SO MAKE IT BIGGER
04500 HRL A,C ;KEEP EVERYBODY UP TO DATE
04600 ADDI B,1 ;CORGET ADDR
04700 CAIG C,MINPDS
04800 JRST PDPRET ;NO PROBLEM
04900 SUBI C,MINPDS ;AMOUNT TO INCREASE BY
05000 ;;# # 4-28-72 DCS UPDATE P'S SIZE FIELD
05100 HRLZ TEMP,C ;UPDATE P RIGHT NOW
05200 SUB P,TEMP ;SIZE FIELD ONLY
05300 ;;# # 4-28
05400 PUSHJ P,CORINC ;INCREMENT TO PROPER SIZE
05500 ERR <DRYROT -- NO CORE FOR SYSTEM_PDL>
05600 ADDI C,MINPDS ;TOTAL SIZE
05700 JRST PDPRET
05800 NOEXP: PUSHJ P,CORGET ;GET A BLOCK
05900 ERR <NO CORE AT ALLOCATION>
06000 PDPRET: TLNN T,WNTADR ;WANT THE ADDRESS STORED?
06100 JRST .+3
06200 MOVEM B,(T) ;YES, STORE IT
06300 ADDI T,1
06400 TLNN T,WNTEND
06500 JRST NOND
06600 MOVE D,C ;SIZE
06700 ADD D,B ;END ADDR
06800 MOVEM D,(T)
06900 ADDI T,1
07000 NOND: PUSHJ P,PDPMAK
07100 TLNE T,WNTPDP
07200 MOVEM B,(T) ;WANTS PDP
07300 PRIN: SKIPN %ALLCHR ;ARE WE BLABBING?
07400 JRST SUBJMP ;NOPE
07500 OUTSTR (A)
07600 PRINT <: >
07700 HLRZ C,A ;SIZE AGAIN
07800 DECPNT C ;TOTAL ALLOC FOR THIS ONE
07900 TERPRI
08000 SUBJMP: SUB P,X22 ;SO MUCH FOR THAT ONE
08100 JRST ALOC ;GET THE NEXT
08200
08300 DONEE: SKIPN %ALLCHR ;BLABBING?
08400 JRST .+3 ; NO
08500 TERPRI↔TERPRI
08600 SUB P,X44 ;→RETURN ADDRESS (DUMMY AND SYSPDL ENTRIES)
00100
00200 ; FINAL BOOKKEEPING
00300
00400 SETZM %RENSW ;DON'T ASK EACH TIME
00500 MOVE SP,SPDL(USER) ;STRING STACK POINTER
00600 MOVE B,ST(USER) ;STRING SPACE BEGINNING
00700 MOVN C,-1(B) ;SIZE
00800 SUBI C,3 ;MINUS OVERHEAD
00900 MOVEM C,STMAX(USER) ;SIZE OF STRING SPACE DATA
01000 HRLI B,(<POINT 7,0>)
01100 MOVEM B,TOPBYTE(USER) ;NEXT FREE BYTE
01200 IMUL C,[-5] ;NUMBER OF FREE CHARS
01300 ;;#GI# DCS 2-2-72 (1-3) MAKE CAT BETTER -- THIS LEAVES SOME ROOM
01400 ADDI C,=15 ;LEAVE SOME SLOP FOR INSET, ETC.
01500 ;;#GI# (1-3)
01600 MOVEM C,REMCHR(USER)
01700 SKIPE CONFIG ;COMPILER?
01800 SETOM SGLIGN(USER) ; YES, STRNGC AND FRIENDS MUST ALIGN STRINGS
01900 HRROI TEMP,KTLNK
02000 POP TEMP,KNTLNK(USER)
02100 POP TEMP,SGROUT(USER)
02200 POP TEMP,SETLNK(USER)
02300 POP TEMP,SPLNK(USER)
02400 POP TEMP,STRLNK(USER);TRANSFER LISTS TO USER TABLE
02500 PUSHJ P,STCLER ;CLEAR OUT ALL STRINGS
02600 MOVEI TEMP,7 ;INITIAL DIGS SETTING
02700 MOVEM TEMP,DIGS(USER) ;FOR FLOATING POINT OUTPUT
02800 MOVEI TEMP,CHANS(USER);IF CHNL HAS A VALID CHANNEL #,
02900 HRLI TEMP,CHNL ; @CDBLOC(USER) REFERS TO ITS
03000 MOVEM TEMP,CDBLOC(USER);CDB ADDR IN THE CHANS TABLE
03100 SETZM %ERGO ;NO AUTOMATIC CONTINUE FROM ERR.
03200 NOEXPO <
03300 MOVNI TEMP,1 ;FIND OUT IF ON A DPY
03400 TTCALL 6,TEMP
03500 MOVEM TEMP,DPYSW ;NEG IF DPY
03600 >;NOEXPO
03700 ;;#HE# DCS 5-11-72 (2-2) MODIFY VERSION CHECKING, STORAGE METHODS
03800 IFNDEF JOBVER,<EXTERNAL JOBVER>
03900 MOVEI LPSA,SPLNEK ;For each element of the space
04000 CHKVRS: SKIPN LPSA,(LPSA) ; list, if there is a non-zero
04100 POPJ P, ; version request, use it (lh is
04200 SKIPN TEMP,$VRNO(LPSA); SAIL version, rh is user version).
04300 JRST CHKVRS ;But if there was a previous non-zero
04400 HLL TEMP,JOBVER ; request, and if it is not the
04500 EXCH TEMP,JOBVER ; same as this one, complain first.
04600 TRNE TEMP,-1
04700 CAMN TEMP,JOBVER
04800 JRST CHKVRS
04900 ERR <VERSION NUMBER MISMATCH>,1
05000 JRST CHKVRS
05100 ;;#HE# (2-2)
05200
05300
05400 PDPMAK: MOVNS C
05500 SUBI B,1 ;PDP
05600 HRL B,C
05700 POPJ P,
05800 >;NOLOW
00100 COMMENT ⊗ Utility Subroutines for allocation
00200 ⊗
00300 DECIN:
00400 OCTIN: AOS (P)
00500 SKIPE %OCTRET ;IMMEDIATE RETURN?
00600 POPJ P, ; YES
00700
00800 SETZB C,D
00900 OCTIN1: TTCALL 0,B
01000 CAIN B,177 ;RUBOUT?
01100 JRST RUB ;AYE, THERE'S THE RUB
01200 CAIN B,"U"-100 ;↑U?
01300 JRST CTRLU ;INDEED
01400 CAIN B,175 ;ALTMODE?
01500 JRST SETRET
01600 CAIN B,12 ;LINE FEED?
01700 JRST EPOP ;YES
01800 CAIL B,"0"
01900 CAILE B,"9" ;I KNOW IT'S CALLED OCTIN,
02000 JRST OCTIN1 ; BUT INPUT IS IN DECIMAL!!
02100 SETOM D ;FOUND SOMETHING LIKE A NUMBER
02200 IMULI C,=10 ;GOOD OLD NUMBER CONVERSION
02300 ADDI C,-"0"(B)
02400 JRST OCTIN1 ;THIS IS A LOOP
02500
02600 SETRET: SETOM %OCTRET ;WILL RETURN IMMEDIATELY HENCEFORTH
02700 TERPRI
02800
02900 EPOP: SKIPE D ;FIND ANYTHING?
03000 SOS (P) ;YES
03100 CPOPJ: POPJ P,
03200
03300 RUB:
03400 CTRLU: TTCALL 3,[BYTE (7) "↑","U",15,12] ;WON'T THE USER BE
03500 JRST OCTIN ;START OVER
00100 SUBTTL %UUOLNK -- UUO Handler (Dispatch Vector Just Below)
00200
00300 NOLOW < ;INCLUDE IN UPPER SEGMENT.....
00400 ↑%UUOLNK:
00500 ↑UUOCON:MOVEM 17,%UACS+17 ;NOTICE UUO0 IS ABOVE HERE
00600 MOVEI 17,%UACS
00700 BLT 17,%UACS+16
00800 MOVE P,[XWD -LUPDL,%UPDL] ;SET UP SPECIAL UUO PDL
00900 MOVE A,JOBUUO ;GET THE INSTRUCTION
01000 LDB B,[POINT 9,A,8] ;GET UUO NUMBER.
01100 TRNE B,-1≠17 ;CHECK IN RANGE
01200 JRST UUOTBL ;ILLUUO
01300 XCT UUOTBL(B) ;GO DO RIGHT THING.
01400 MOVSI 17,%UACS
01500 BLT 17,17 ;RELOAD ACCUMULATORS.
01600 JRST 2,@UUO0
01700
01800 ; UUO TABLE
01900
02000 ↑↑UUOTBL:PUSHJ P,ILLUUO ;0
02100 PUSHJ P,PDLOQ ;1
02200 PUSHJ P,FLOAQ ;2
02300 PUSHJ P,FIXQ ;3
02400 PUSHJ P,IOERRR ;4
02500 PUSHJ P,ERRR ;5
02600 PUSHJ P,PSIX ;6 -- SIXBIT PRINT.
02700 PUSHJ P,ARERRR ;7 -- ARRAY ERROR
02800 PUSHJ P,ILLUUO ;10
02900 PUSHJ P,DECPNQ ;11
03000 PUSHJ P,OCTPNQ ;12
03100 PUSHJ P,FLTPNQ ;13
03200 PUSHJ P,ILLUUO ;14
03300 PUSHJ P,ILLUUO ;15
03400
03500 FLTPNQ: TERPRI (<WELL ONE FLOATING PT NUMBER IS 1.0>)
03600 JRST GODD
00100 SUBTTL ILLUUO, PDLOV, ERR UUO Handlers
00200
00300 DSCR ERROR UUOS
00400 PAR AC FIELD IS INDEX INTO ERROR ROUTINE
00500 SID SAVES THE WORLD
00600 DES THE ASCIZ STRING INDICATED BY THE EFFECTIVE ADDRESS IS TYPED. THEN
00700 THE ERROR ROUTINE INDICATED BY THE AC FIELD IS EXECUTED.
00800 IF `GO' IS NOT ON, THE USER IS ALLOWED TO RESPOND WITH ONE OF SEVERAL
00900 ALTERNATIVES. ONE ALTERNATIVE IS CONTINUATION IF THE AC FIELD OF THE
01000 UUO WAS ODD. OTHERWISE, NO CONTINUATION IS POSSIBLE. THE ACS AT THE
01100 TIME OF CALL ARE RESTORED IF CONTINUATION OR `DDT' IS CHOSEN.
01200 ⊗
01300
01400 ILLUUO: SKIPA A,[10B12+[ASCIZ /ILLEGAL UUO /]]
01500 PDLOQ: MOVEI A,[ASCIZ /PDL OVERFLOW/]
01600 ERRR: ERSEEN←←10000
01700 SKIPL CONFIG ;COMPILER ??
01800 JRST NOCOM
01900 TLNE FF,ERSEEN ;IF SYNTAX ERRORS HAVE OCCURED, ONLY
02000 JRST [TLNE A,40 ;HALT IF THIS IS AN UNRECOV. ERROR.
02100 POPJ P, ;JUST CONTINUE....
02200 TTCALL 3,(A) ;PRINT THE OFFENDING MESSAGE
02300 TERPRI <CANNOT CONTINUE ANY FARTHER>
02400 SETZM %RECOV ;NOT A CHANCE
02500 JRST WATNOW]
02600 NOCOM:
02700 NOEXPO <
02800 PUSHJ P,PPRESET ;TURN ON PP 0, RESET POSITION
02900 >;NOEXPO
03000
03100 TTCALL 3,(A) ;PRINT MESSAGE
03200 LDB B,[POINT 4,A,12] ;DISPATCH INDEX
03300 ROT B,-1 ;LOW ORDER BIT TO SIGN BIT
03400 MOVEM B,%RECOV ;MARK %RECOVERABLE (OR NOT)
03500 PUSHJ P,@URTBL(B) ;CALL ERROR ROUTINE
03600 MOVEI A,0 ;INFO FOR MYERR
03700 SKIPE ERRSPC ;SPECIAL ERROR ROUTINE??
03800 PUSHJ P,@ERRSPC ;YES -- GO DO IT.
03900
04000 LINDUN: TERPRI
04100 PRINT <CALLED FROM >
04200 HRRZ A,UUO0
04300 SUBI A,1
04400 PUSHJ P,OCTPNQ+1
04500 SKIPGE CONFIG ;RUNTIMES OR GAG
04600 JRST NOLSCL
04700 PRINT < LAST SAIL CALL AT >
04800 MOVE A,GOGTAB
04900 HRRZ A,UUO1(A)
05000 SOS A
05100 PUSHJ P,OCTPNQ+1
05200
05300 NOLSCL: TERPRI
05400 MOVE A,GOGTAB
05500 HRRZ B,TOPBYTE(A)
05600 CAML B,STTOP(A);HAVE WE GONE OFF THE DEEP END?
05700 JRST [PRINT <ALL BETS ARE OFF, FOLKS!
05800 STRING SPACE EXHAUSTED UNEXPECTEDLY. WILL RESTART NOW>
05900 JRST @JOBREN]
06000
06100 SKIPE %ERGO
06200 JRST GOTRY ;AUTOMATIC CONTINUE SET
06300 WATNOW:
06400 IFN IMSSS,<
06500 COMMENT !
06600 IF WE HAVE A KIDDY JOB, THEN LOG OUT GRACEFULLY.
06700 WE FIND OUT THAT WE HAVE A KIDDY JOB BY THE CNTSZ JSYS.
06800 !
06900 OPDEF CNTSZ [104000000607] ;NO. OF FORKS
07000 OPDEF GJINF [104000000013] ;JOB INFO( E.G., THE #)
07100 OPDEF PSOUT [104000000076] ;PRINT A STRING
07200 OPDEF KLGOT [104000000613] ;KIDDY LOGOUT
07300 PUSH P,A ;SAVE ACS
07400 PUSH P,B
07500 PUSH P,C
07600 PUSH P,D
07700 GJINF ;GET JOB INFORMATION
07800 MOVE A,C ;GET THE JOB NO. IN 1
07900 CNTSZ
08000 HLRZ A,B ;# OF FORKS (LH OF 2)
08100 CAIG A,1 ;MORE THAN 1?
08200 JRST [HRROI 1,[ASCIZ/
08300 SORRY, SYSTEM ERROR.
08400
08500 GOODBYE.
08600 /]
08700 PSOUT
08800 SETO 1,
08900 KLGOT ;LOGOUT
09000 ] ;END OF LITERAL
09100
09200 POP P,D ;RESTORE
09300 POP P,C
09400 POP P,B
09500 POP P,A
09600
09700 >;IFN IMSSS
09800
09900 MOVEI A,"?" ;PRINT ? FOR IRRECOVERABLE ERRORS,
10000 SKIPGE %RECOV ; → FOR %RECOVERABLE ONES.
10100 EXPO <
10200 MOVEI A,"↑" ;SOMETHING PRINTABLE
10300 >;EXPO
10400 NOEXPO <
10500 MOVEI A,"→" ;FOR %RECOVERABLE ONES
10600 >;NOEXPO
10700 TTCALL 1,A ;PRINT IT
10800 NOEXPO <
10900 SKIPGE DPYSW ;ON A DPY?
11000 DPYOUT 7,DPYMBK ; FLASHING INSTRUCTIONS
11100 >;NOEXPO
11200 TTCALL 0,B ;GET RESPONSE CHAR
11300 CAIL B,"a" ;lower case?
11400 SUBI B,40 ;YES, CONVERT TO UPPER
11500 NOEXPO <
11600 SKIPGE DPYSW
11700 DPYOUT 7,[0↔0] ;TURN OFF ALL THAT FLASHING
11800 >;NOEXPO
11900 CAIN B,"E" ;RE-EDIT?
12000 JRST EDIT ; YES
12100 CAIN B,"T" ;USE TV?
12200 JRST TVEDIT ; YES
12300 TTCALL 11, ;CLEAR INPUT BUFFER
12400 CAIN B,12 ;CONTINUE AUTOMATISCH?
12500 SETOM %ERGO ;YES
12600
12700 CAILE B,15 ;TRY TO CONTINUE?
12800 JRST NOCR
12900
13000 CAIE B,"α" ;CONTINUE ANYWAY OR
13100 GOTRY: SKIPGE %RECOV ;CAN WE CONTINUE?
13200 POPJ P, ;YES
13300
13400 TERPRI <CAN'T CONTINUE>
13500 JRST WATNOW
13600
13700 NOCR: CAIN B,"S"
13800 JRST STRTIT ;RESTART
13900 CAIN B,"X" ;EXIT?
14000 JRST [
14100 MOVSI 17,%UACS
14200 BLT 17,17
14300 CALL6 EXIT]
14400
14500 NOXIT: CAIE B,"D"
14600 JRST BADRSP ;DOESN'T KNOW WHAT HE WANTS
14700 GODD: SKIPN JOBDDT ;IS DDT IN CORE
14800 JRST NODDT ;NOPE
14900 MOVSI 17,%UACS
15000 BLT 17,17
15100 JRST @JOBDDT
15200
15300 NODDT: TERPRI <NO DDT>
15400 JRST WATNOW
00100
00200 BADRSP: SKIPE A,ERRSPC ;IS THERE A COMPILER ROUTINE?
00300 SKIPN A,-1(A) ;YES, IS THERE AN FTDEBUGGER?
00400 JRST RELYBD ;NO OR NO
00500 CAIE B,"L" ;WANT TO LOOK AT STACK?
00600 JRST RELYBD ;NO, ALL THAT WORK FOR LITTLE
00700 TERPRI <YOU ARE IN THE COMPILER DEBUGGER>
00800 PUSHJ P,(A) ;GO DEBUG
00900 JRST WATNOW
01000
01100 RELYBD: PRINT <REPLY [CR] TO CONTINUE,
01200 [LF] TO CONTINUE AUTOMATICALLY,
01300 "D" FOR DDT, "E" TO EDIT,
01400 "X" TO EXIT, "S" TO RESTART>
01500 JUMPE A,CRL
01600 PRINT <,
01700 "L" TO LOOK AT THE STACK>
01800 CRL: TERPRI
01900 JRST WATNOW
02000
02100
02200 IOERRR: TERPRI
02300 TTCALL 3,(A)
02400 TLNE A,740 ;ANY AC AT ALL?
02500 PUSHJ P,SIXPRT ;YES, ASSUME 14-15, SIXBIT IN LPSA
02600 TERPRI
02700 CALLI ;AVOID CLOSING FILES
02800 CALL [SIXBIT/EXIT/] ;FAIL WON'T LET ME USE CALL6
02900 STRTIT: HRRZ A,JOBSA
03000 JRST (A)
03100
03200
03300 DSCR ARRAY ERROR UUO
03400 PAR ARRAY NAME STRING DESCRIPTOR ADDRESS IS EFFECTIVE ADDR
03500 INDEX NUMBER IS AC FIELD.
03600 DES ARRAY NAME, INDEX NUMBER ARE PRINTED. THEN ERROR UUO CODE
03700 IS ENTERED AS ABOVE.
03800 ⊗
03900
04000 ARERRR:
04100 NOEXPO <
04200 PUSH P,PPRETR ;IN LINE CALL
04300 PPRESET:
04400 SKIPL DPYSW ;ON A DPY?
04500 POPJ P, ;NO, DON'T BOTHER
04600 OPDEF PPIOT [702B8]
04700 PPIOT 1,400000
04800 DPYPOS (-200) ;RESET X POS
04900 DPYSIZ (3,5) ;RESET GLITCHES
05000 PPRETR: POPJ P,.+1
05100 >;NOEXPO
05200 PRINT <INVALID INDEX NO. >
05300 LDB A,[POINT 4,JOBUUO,12]
05400 PUSHJ P,DECPNQ+1
05500 PRINT < FOR ARRAY >
05600 SETZM %RECOV ;NON-RECOVERABLE ERROR!
05700 PUSHJ P,PRASC
05800 JRST LINDUN
00100 SUBTTL Special Printing Routines For Error Handler
00200
00300 DSCR UUO ERROR MESSAGE ROUTINES AND THEIR INDICES (AC FIELD OF UUO)
00400 ⊗
00500
00600 ↑↑URTBL:UPOPJ ; 0- 1 -- NO ACTION
00700 .PRSM ; 2- 3 -- PRINT SYMBOL PTD TO BY LPSA (SAIL)
00800 PRASC ; 4- 5 -- PRINT SYMBOL PTD TO BY UUO INSTR
00900 ACPRT ; 6- 7 -- PRNT VAL OF AC IN INSTR PRECDNG UUO
01000 UUOPRT ;10-11 -- PRINT THE UUO
01100 AC1PRT ;12-13 -- PRINT AC FIELD ASSUMING RETURN FROM
01200 ; CALL IS IN UUO1(GOGTAB)
01300 SIXPRT ;14-15 --PRINT LPSA AS SIXBIT
01400
01500 UUOPRT: HLRZ A,40 ;LH
01600 PUSHJ P,OCTPNQ+1 ;TYPE IT
01700 HRRZ A,40 ;RH
01800 JRST OCTPNQ+1 ;IT TOO
01900
02000 DSCR PRSYM -- PRINT SYMBOL NAME
02100 PAR SAIL SEMANTICS BLOCK ADDRESS IN LPSA
02200 RES TYPES $PNAME STRING FROM BLOCK
02300 SID DESTROYS A,B
02400 ⊗
02500
02600
02700 $PNAME ←← 1
02800
02900 PRASC: SKIPA A,JOBUUO ;→STRING DESCRITPOR
03000 .PRSM: HRRI A,$PNAME(LPSA) ;→STRING DESCRIPTOR
03100 HRRZ B,(A) ;#CHARACTERS
03200 MOVE A,1(A) ;STRING BP
03300 MOVEI D,0 ;NO ADJUSTMENT
03400 JRST PRSL1 ;WON'T WORK FOR ZERO LENGTH STRINS
03500
03600 PRSL: ILDB C,A ;CHARACTER
03700 ADDI C,(D) ;ADJUSTMENT
03800 TTCALL 1,C ;TYPE IT
03900 PRSL1: SOJGE B,PRSL
04000 UPOPJ: POPJ P,
04100
04200
04300 AC1PRT: MOVE A,GOGTAB ;GET USER TABLE PTR
04400 SKIPA A,UUO1(A) ;SOMEONE STORED RIGHT THING HERE
04500
04600 ACPRT: HRRZ A,UUO0
04700 LDB A,[POINT 4,-2(A),12] ;AC # FROM PREV INSTR
04800 ADDI A,%UACS
04900 JRST DECPNQ ;PRINT IT IN DECIMAL
05000
05100 SIXPRT: SKIPA A,[POINT 6,LPSA];GET FROM HERE
05200 PSIX: HRLI A,(<POINT 6,0>) ;UUO ADDR IS ADDR OF SIXBIT
05300 MOVEI D,40 ;ADJUSTMENT
05400 MOVEI B,6 ;PRINT 6 CHARS
05500 JRST PRSL1
05600
00100 SUBTTL Code to Handle Linkage to Editors
00200
00300 TVEDIT: TDZA 13,13 ;FLAG AS TV
00400 EDIT: MOVNI 13,1
00500 PUSH P,13
00600 SETZB 13,14 ;PREPARE FOR PROVIDING
00700 SETZB 15,16 ;STOPGAP WITH FILE NAME,
00800 SETZB 11,12 ; PAGE AND LINE NUMBERS, SEQUENTIAL LINE #
00900 IFN IMSSS,<
01000 MOVEI A,1 ;INDICATE EDITING
01100 SKIPE ERRSPC ;ERROR ROUTINE SPECIFIED?
01200 PUSHJ P,@ERRSPC ;YES
01300 >;IFN IMSSS
01400
01500 TTCALL 0,B ;SEE IF FILE NAME SPECIFIED
01600 CAIE B,15 ;CR?
01700 JRST GTNAM ; NO, NAME SPECIFIED
01800
01900 AUTO: TTCALL 0,B ;SNARF UP LINE FEED AFTER CR
02000 MOVEI A,1
02100 SKIPE ERRSPC
02200 PUSHJ P,@ERRSPC ;SPECIAL FOR COMPILER....
02300 JRST GTIT ;GET QQSVED.RPG
02400
02500 GTNAM: CAIE B," " ;DELETE LEADING BLANKS
02600 JRST MKNAMM
02700 TTCALL 0,B
02800 JRST GTNAM
02900
03000 MKNAMM: CAIN B,15 ;GO BACK ON CR
03100 JRST AUTO
03200 MOVE C,[POINT 6,13] ;COLLECT FILE NAME HERE
03300 MKNLP: CAIE B," " ;DONE?
03400 CAIN B,15
03500 JRST GTIT1 ; YES
03600 SUBI B,40
03700 CAIN B,"."-40
03800 SKIPA C,[POINT 6,14] ;ADJUST TO GET EXTENSION
03900 IDPB B,C ;CHAR OF FILENAME
04000 TTCALL 0,B
04100 JRST MKNLP
04200
04300
04400 GTIT1: CAIN B,15
04500 TTCALL 0,B
04600
04700 GTIT: POP P,A ;TV/SOS FLAG
04800 EXCH 13,14 ;EXT IN REG PRECEDING NAME?
04900 ;HERE TO RUN ANY PROGRAM, EITHER SOS OR COMPIL.
05000 ; REGISTERS HAVE GOODIES IN THEM:
05100 ; 13 FILE EXTENSION IN SIXBIT
05200 ; 14 FILE NAME IN SIXBIT
05300 ; 15 LINE NUMBER IN ASCII.
05400 ; 16 PAGE NUMBER (BINARY)
05500 ;IF AC 14 IS ZERO, THIS MEANS NO FILE HAS BEEN
05600 ; SPECIFIED, AND WE WILL USE "COMPIL" TO REPEAT THE
05700 ; LAST EDIT COMMAND (THIS IS NOT A FEATURE ON MOST
05800 ; STANDARD DEC SYSTEMS -- SEE R SPROULL)
05900 NOEXPO <
06000 MOVEI P,2
06100 LOAD6 (2,<SYS>) ;ASSUME GET TO EDITOR VIA RPG
06200 LOAD6 (4,<DMP>)
06300 MOVEI 6,0
06400 MOVEI 5,777777 ;TELLS RPG: "EDIT"
06500 LOAD6 (3,<RPG>)
06600 JUMPE 14,SWAPIT
06700 MOVEI 5,1 ;START AT RPG LOC IN EDITOR
06800 LOAD6 (3,<SOS>) ;NOW ASSUME SOS
06900 JUMPL A,SWAPIT ;YES
07000 LOAD6 (3,<TV>) ;NO, TV
07100 MOVE 15,12 ;GET SEQUENTIAL LINE NUMBER
07200 SWAPIT: CALL6 (P,SWAP) ;SEE YOU AROUND
07300 >;NOEXPO
07400 ; ELSE FALL INTO EXPO VERSION ....
00100
00200 COMMENT ⊗ EXPORT VERSION OF EDITOR-INTERFACE
00300 PROVIDED BY R. SPROULL, 11-18-70
00400 SEE HIM FOR DETAILS ON DIDDLES TO CCL AND EDIT10
00500 ⊗
00600 EXPO <
00700 JUMPN 14,EDITG ;IF FILE, FIRE UP SOS
00800 MOVE P,[XWD -1,[SIXBIT /SYS/
00900 SIXBIT /COMPIL/
01000 0 ↔ 0 ↔ 0 ↔ 0 ]]
01100 CALL6 (P,RUN) ;GO RUN IT.
01200 JRST 4,0
01300 EDITG: PUSHJ P,RPGDSK ;SET UP FOR FILE
01400 MOVE 2,14 ;GET THE FILE
01500 PUSHJ P,SXCON
01600 MOVEI 1,"."
01700 SKIPN 2,13 ;EXTENSION
01800 JRST NOEXT
01900 PUSHJ P,OUT1
02000 HLLZS 2 ;EXTENSION.
02100 PUSHJ P,SXCON
02200 NOEXT: SKIPN 11 ;PROJ,PROG #
02300 JRST NOPPN
02400 MOVEI 1,"["
02500 PUSHJ P,OUT1
02600 HLRZ 1,11
02700 PUSHJ P,OCTO ;OUTPUT OCTAL
02800 MOVEI 1,","
02900 PUSHJ P,OUT1
03000 HRRZ 1,11
03100 PUSHJ P,OCTO
03200 MOVEI 1,"]"
03300 PUSHJ P,OUT1
03400 NOPPN: PUSHJ P,CRLF
03500 JUMPE 15,GOED10 ;IF NO LINE NUMBER, DO NOT DO THIS.
03600 MOVEI 1,"P"
03700 PUSHJ P,OUT1
03800 MOVE 2,15 ;LINE NUMBER
03900 TRZ 2,1 ;FOR SURE?
04000 ASCO: MOVEI 1,0
04100 LSHC 1,7
04200 PUSHJ P,OUT1
04300 JUMPN 2,ASCO
04400 MOVEI 1,"/"
04500 PUSHJ P,OUT1
04600 MOVE 1,16 ;PAGE NUMBER
04700 PUSHJ P,OUTDEC
04800 PUSHJ P,CRLF
04900 GOED10: MOVE 1,PPMAX+2 ;SIZE
05000 ADDI 1,4
05100 IDIVI 1,5 ;TO WORDS
05200 MOVNS 1
05300 HRLS 1
05400 HRR 1,PPMAX ;BUFFER START
05500 ADDI 1,1
05600 MOVEM 1,PPMAX+2
05700 MOVSI 1,'EDT'
05800 EXCH 1,PPMAX+1
05900 MOVE 2,[XWD 3,PPMAX+1]
06000 CALLI 2,44 ;WRITE IT
06100 JRST DSKIT
06200 EDT10R: MOVE P,[XWD 1,[SIXBIT /SYS/
06300 SIXBIT /SOS/
06400 0↔0↔0↔0]]
06500 CALL6 (P,RUN)
06600 JRST 4,.
06700 DSKIT: SETSTS 1,16 ;DO NOT LOSE BUFFERS
06800 MOVEM 1,PPMAX+1
06900 CALLI 2,30 ;JOB NUMBER
07000 MOVSI 1,'EDT' ;TO FILE NAME
07100 MOVEI 4,3
07200 DGLP: IDIVI 2,=10
07300 IORI 1,20(3)
07400 ROT 1,-6
07500 SOJG 4,DGLP
07600 MOVSI 2,'TMP'
07700 SETZB 3,4
07800 ENTER 1,1
07900 CALLI 12 ;FATAL
08000 SETSTS 1,0
08100 CLOSE 1,0 ;FINISH
08200 JRST EDT10R
08300 RPGDSK: CALLI
08400 INIT 1,0
08500 SIXBIT /DSK/
08600 XWD PPMAX,0
08700 CALLI 12
08800 OUTBUF 1,0
08900 OUTPUT 1,0
09000 SETZM PPMAX+2
09100 MOVEI 1," "
09200 OUT1: AOS PPMAX+2
09300 IDPB 1,PPMAX+1
09400 POPJ P,
09500 SXCON: MOVEI 1,0
09600 LSHC 1,6
09700 ADDI 1,40
09800 PUSHJ P,OUT1
09900 JUMPN 2,SXCON
10000 POPJ P,
10100 OCTO: IDIVI 1,10
10200 HRLM 2,(P)
10300 SKIPE 1
10400 PUSHJ P,OCTO
10500 HLRZ 1,(P)
10600 ADDI 1,"0"
10700 JRST OUT1
10800 OUTDEC: IDIVI 1,=10
10900 HRLM 2,(P)
11000 SKIPE 1
11100 PUSHJ P,OUTDEC
11200 HLRZ 1,(P)
11300 ADDI 1,"0"
11400 JRST OUT1
11500 CRLF: MOVEI 1,15
11600 PUSHJ P,OUT1
11700 MOVEI 1,12
11800 JRST OUT1
11900 >;EXPO
00100 SUBTTL DECPNT, OCTPNT, FIX, FLOAT UUOs
00200
00300 DSCR OCTPNT, DECPNT UUO'S
00400 PAR ADDR OF WORD TO BE PROCESSED IS EFFECTIVE ADDR
00500 RES DECPNT -- WORD TYPED IN DECIMAL
00600 OCTPNT -- OCTAL
00700 ⊗
00800
00900
01000
01100 OCTPNQ: HRRZ A,(A)
01200 MOVEI C,10 ;KEEP RADIX IN C.
01300 JRST PNT
01400
01500 DECPNQ: MOVE A,(A)
01600 MOVEI C,=10
01700 JUMPGE A,PNT ; GREATER 0.
01800 PRINT <->
01900 MOVMS A ; FOO1 ← ABS(FOO1);
02000 PNT: IDIV A,C ;FAMOUS DEC RECURSIVE NUMBER PRINTER.
02100 IORI B,"0"
02200 HRLM B,(P)
02300 SKIPE A
02400 PUSHJ P,PNT
02500 HLRZ B,(P)
02600 TTCALL 1,B
02700 POPJ P,
02800
02900 DSCR FIX UUO (FIXQ)
03000 PAR EFFECTIVE ADDR → WORD TO BE CONVERTED
03100 RES FIXED POINT EQUIVALENT IN AC SPECIFIED IN AC FIELD OF UUO
03200 ⊗
03300 FIXQ: TRNN A,777760 ;IN AC?
03400 ADDI A,%UACS ;YES
03500 MOVE B,(A) ;GET ARGUMENT
03600 MULI B,400 ;THIS ALGORITHM STOLEN FROM F4.
03700 TSC B,B
03800 EXCH B,C
03900 ASH B,-243(C)
04000 JRST FXFLT ;STORE IN RIGHT PLACE.
04100 POPJ P,
04200
04300 DSCR FLOAT UUO (FLOAQ)
04400 RES LIKE FIX, BUT RETURNS FLOATING POINT EQUIVALENT OF ITS ARGUMENT
04500 ⊗
04600 FLOAQ: TRNN A,777760 ;IN AC?
04700 ADDI A,%UACS ;YES
04800 MOVE B,(A) ;GET ARGUMENT
04900 IDIVI B,1B18
05000 SKIPE B
05100 TLC B,254000
05200 TLC C,233000
05300 FAD B,C
05400 FXFLT:
05500 LDB A,[POINT 4,A,12] ;RESULT REGISTER
05600 MOVEM B,%UACS(A) ;STORE RESULT
05700 POPJ P,
00100 SUBTTL DSPLIN, etc.for Disp. Text Line on Error (Compiler)
00200
00300 DSCR DPYCLR
00400 CAL PUSHJ
00500 RES RESETS III DPY STATE IF A III DPY IS AROUND
00600 ⊗
00700
00800 NOEXPO <
00900 ↑DSPCLR:
01000 SKIPGE DPYSW
01100 DPYCLR
01200 POPJ P,
01300
01400 >;NOEXPO
01500
01600
01700 NOEXPO <
01800 ↑↑DPYMBK: DPYMSG
01900 DPYSVV-DPYMSG+1 ;DPYOUT HEADER BLOCK
02000
02100 DPYMSG: 0
02200 AIVECT (=100,=400) ;MOVE TO RIGHTOF RAID SCREEN
02300 ASCID /REPLY [CR] TO CONTINUE,
02400 /
02500 RIVECT (=612,0) ;GET OUT THERE AGAIN
02600 ASCID ([LF] TO CONTINUE AUTOMATICALLY,
02700 (
02800 RIVECT (=612,0)
02900 ASCID ("D" FOR DDT, "E" TO EDIT, "T" TO TVEDIT,
03000 (
03100 RIVECT (=612,0)
03200 ASCID ("X" TO EXIT, "S" TO RESTART,
03300 (
03400 DPYSVV: DPYJMP DPYMSG
03500
03600 >;NOEXPO
00100 SUBTTL SAVE, RESTR, INSET -- General Utility Routines
00200
00300 DSCR SAVE
00400 CAL PUSHJ
00500 DES This routine saves registers 0-CHNL (12) in the user
00600 RACS area. It also saves the return
00700 address (-1(P)) in UUO1(USER), for traditional reasons,
00800 for the error message printout routines.
00900 Register USER is loaded but not saved, as is register
01000 TEMP
01100 ⊗
01200 ↑SAVE: MOVE USER,GOGTAB ;→USER RE-ENTRANT TABLE
01300 HRRZI TEMP,RACS(USER) ;XWD FF,SAVEADDR
01400 BLT TEMP,RACS+CHNL(USER) ;SAVE FF THRU CHNL
01500 MOVE TEMP,-1(P) ;RETURN ADDR FROM I/O CALL
01600 MOVEM TEMP,UUO1(USER) ;STORE RETURN
01700 POPJ P,
01800
01900 DSCR RESTR
02000 PAR LPSA -- XWD FOR ADJUSTING P-STACK (#PARAMS+RETURN ADDR)
02100 CAL JRST
02200 RES ACS are restored from RACS, stack is adjusted using LPSA,
02300 return is made through UUO1(USER)
02400 ⊗
02500
02600 ↑RESTR: MOVSI TEMP,RACS(USER) ;XWD SAVEADDR,FF
02700 BLT TEMP,CHNL ;RESTORE
02800 SUB P,LPSA ;ADJUST STACK
02900 JRST @UUO1(USER) ;RETURN
03000
03100 DSCR STACSV
03200 CAL PUSHJ
03300 DES SAVES ACS 0-13 IN AREA STACS
03400 SID DESTROYS 14,15
03500 ⊗
03600 ;; #KL# BY JRL (11-22-72) SAVE ONLY AC'S 0-13
03700 ↑STACSV:
03800 MOVE 15,GOGTAB
03900 HRRZI 14,STACS(15)
04000 BLT 14,STACS+13(15)
04100 POPJ P,
04200
04300 DSCR STACRS
04400 CAL PUSHJ
04500 DES RESTORES ACS 0-13 FROM AREA STACS
04600 ⊗
04700
04800 ;; #KL# RESTORE ONLY 0-13
04900 ↑STACRS: MOVE 15,GOGTAB
05000 HRLZI 14,STACS(15)
05100 BLT 14,13
05200 POPJ P,
05300
05400
05500
05600 DSCR INSET
05700 CAL PUSHJ
05800 RES String Space is adjusted so that next created string will start
05900 on a full-word boundary.
06000 SID USER→GOGTAB
06100 DES REMCHR is first adjusted, and STRNGC called if necessary.
06200 Then TOPBYTE is adjusted.
06300 ⊗
06400
06500
06600 ↑INSET: MOVE USER,GOGTAB ;MAKE SURE
06700 ;;#GI# DCS 2-5-72 REMOVE TOPSTR
06800 HLL TEMP,TOPBYTE(USER)
06900 HRRI TEMP,[BYTE (7) 0,4,3,2,1,0]
07000 ILDB TEMP,TEMP ;ADJUSTMENT NEEDED.
07100 ADDM TEMP,REMCHR(USER) ;UPDATE REMCHR.
07200 SKIPL TEMP,TOPBYTE(USER)
07300 ADDI TEMP,1
07400 HRLI TEMP,440700 ;POINT 7, WORD
07500 MOVEM TEMP,TOPBYTE(USER) ;AND SAVE
07600 POPJ P,
07700 >;NOLOW
07800 ENDCOM(LUP)
07900 COMPIL(COR,<CORREL,CORGET,CORINC,CANINC,CORBIG>
08000 ,<GOGTAB>
08100 ,<CORGET, CORREL, ... -- CORE ALLOCATION ROUTINES>)
00100 SUBTTL Core Service Routines -- General Description
00200
00300 DSCR BEGIN CORSER
00400 ⊗
00500 IFN ALWAYS,<BEGIN CORSER>
00600 Comment ⊗ These are the core allocation routines for both the compiler
00700 and the code it compiles. Core comes in "BLOCKs." A block may be any
00800 (reasonable) length, and has the following format:
00900
01000 HEAD: →PREV,,→NEXT ;if block not in use, free storage list pointers
01100 SIZE ;GREATER 0 if free, LESS0 if in use
01200 <SIZE-3 data words> ;whatever is to go here
01300 x00000,,→HEAD ;x=1 if in use, 0 if free
01400
01500 →PREV is zero if this block is first on free storage list. →NEXT is zero if last
01600
01700 In the beginning, the world starts out as one big block, occupying space from
01800 the end of the (GOGTAB→) user table to @JOBREL. Once a MOVE USER,GOGTAB
01900 has been done, LOWC(USER) and TOP(USER) indicate the total size of
02000 available core. FRELST(USER) → the first (only) block in free storage.
02100
02200 If GOGTAB is 0, CORGET will create a user table and make the remaining space
02300 look like a BLOCK. It will create a user table and point GOGTAB at it.
02400 It also assures that DDT symbols are below JOBSA(lh). Then it sets
02500 JOBFF to =76K out of pure spite. Now CORGET operations may be issued.
02600
02700 CORGET is called with the desired size in SIZ (C). The free storage list is
02800 searched for the first free block (BLK) satisfying the request. The
02900 required block is taken from lower addresses of BLK and BLK is adjusted.
03000 If requested size is within a few words of the free size, all of BLK is
03100 given to the user. The resultant address is returned in THIS (B).
03200
03300 If there is no block on FRELST(USER) big enough, or if ATTOP(USER) ≠ 0, CORGET
03400 checks XPAND(USER) for permission (0) to expand core. If granted, a new
03500 block is formed at the top after obtaining more core. It is merged with
03600 the top block if it is free, then the requested block is allocated from
03700 it. CORGET is simple.
03800
03900 CORGET skips if it is successful. It does not skip if it needs to expand and
04000 either XPAND(USER) ≠ 0 or the CORE UUO fails.
04100
04200 The secret is CORREL. No compacting is done, but CORREL will merge a returning
04300 block with any neighboring free block. It can do this because it can
04400 tell the status of each neighbor by looking at the size (POS if free)
04500 field or x-bit (off if free). This tends to reduce checkerboarding.
04600
04700 CORREL is called with a pointer to the block to be released in THIS (B).
04800 It returns nothing, nor does it ever skip.
04900
05000 CORBIG returns in SIZ the size of the largest available block. ⊗
05100 NOLOW < ;INCLUDE IN UPPER SEGMENT.
00100 SUBTTL Special AC Declarations
00200
00300 DEBCOR ←←0 ;SWITCH FOR CORE DEBUGGING ROUTINES.
00400 ; ACS
00500
00600 SIZ ←← 3 ;SIZE OF BLOCK BEING OBTAINED OR RELEASED
00700 THIS ←← 2 ;POINTER TO SAME
00800 NEXT ←← 1 ;POINTER TO SUCCESSOR
00900 PREV ←← 5 ;POINTER TO PREDECESSOR
01000 LAST ←← 6 ;POINTER TO NEXT-HIGHER NEIGHBOR
01100
01200 TRIVIAL ←←=10 ;AMOUNT WE'RE WILLING TO WASTE
00100 SUBTTL Utility Routines
00200
00300 DSCR UNLINK
00400 CAL PUSHJ
00500 PAR →Core block to be removed in AC THIS (2)
00600 RES block is removed from CORSER free storage list
00700 SID ACs NEXT (1) and PREV (5) are given appropriate values
00800 ⊗
00900
01000 UNLINK:
01100 HRRZ NEXT,(THIS) ;→NEXT BLOCK
01200 HLRZ PREV,(THIS) ;→PREVIOUS BLOCK
01300 SKIPN PREV ;IF A PREV BLOCK DOES NOT EXIST,
01400 MOVEI PREV,FRELST(USER) ; USE FRELST POINTER
01500 HRRM NEXT,(PREV) ;CHANGE ITS NEXT FIELD
01600 SKIPE NEXT ;IF A NEXT BLOCK EXISTS,
01700 HRLM PREV,(NEXT) ; CHANGE ITS PREV FIELD
01800 POPJ P, ;BLOCK IN "THIS" IS NO LONGER ON FRELST
01900
02000 DSCR RELINK
02100 CAL PUSHJ
02200 PAR AC THIS → core block to be placed on free storage list
02300 AC LAST → last word of block +1
02400 AC SIZ has size of this block
02500 DES block is placed on CORSERs free storage list
02600 SID AC NEXT (1) is given the appropriate value
02700 ⊗
02800
02900 RELINK:
03000 HRRZM THIS,-1(LAST) ;X-BIT ← 0, RH ← PTR TO HEAD
03100 MOVEM SIZ,1(THIS) ;GREATER 0 SIZE FIELD ⊃ FREE BLOCK
03200 SKIPE NEXT,FRELST(USER) ;PLACE NEW BLOCK ON FRONT OF FRELST
03300 HRLM THIS,(NEXT) ; IF THERE IS ONE
03400 HRRZM NEXT,(THIS) ;POINT TO NEXT FROM THIS
03500 HRRZM THIS,FRELST(USER) ;UPDATE FRELST POINTER
03600 POPJ P, ;RETURN
03700
03800 DSCR CORE2I
03900 CAL PUSHJ
04000 DES Initializes second segment core if there is a global model
04100 ⊗
04200
04300 GLOB <
04400 IFN 0,<
04500 ↑GLCOR:
04600 SKIPE GLBPNT
04700 POPJ P, ;ALREADY INITIALIZED.
04800 MOVEM 16,GLUSER+LEABOT+16
04900 MOVEI 16,GLUSER+LEABOT
05000 BLT 16,GLUSER+LEABOT+15
05100 ;SHALL NOT CLOBBER ACCUMULATOR 1.
05200 MOVEI 3,3(13) ;GET SIZE REQUIRED.PLUS SOME BECAUSE BLT LOSES.
05300 PUSHJ P,CORE2 ;GET SECOND SEGMENT CORE.
05400 JRST [TERPRI <NO CORE FOR GLOBAL MODEL>
05500 CALLI 12]
05600 SUBI 2,1
05700 MOVEM 2,GLBPNT ;AND RECORD IT.
05800 SETZM 1(2) ;FIRST WORD.
05900 HRRI 2,2(2) ;SECOND WORD.
06000 HRLI 2,-1(2) ;FIRST WORD.
06100 ADDI 3,-2(2) ;LENGTH.
06200 BLT 2,(3) ;ZERO IT.....
06300 MOVSI 16,GLUSER+LEABOT
06400 BLT 16,16 ;RESTORE ALL LOADER'S AC'S AGAIN.
06500 POPJ P, ;AND GO AWAY.
06600 >
06700 ↑CORE2I:
06800 PUSH P,USER
06900 MOVE USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
07000 SETZM GLUSER+LEABOT+20
07100 BLT USER,GLUSER+ZAPEND
07200 POP P,USER ;NOW DATA AREA IS ZERO.
07300 MOVEI USER,GLUSER ;SET UP FOR CORE2.
07400 PUSHJ P,JUSTSAVE ;AND SAVE AC'S
07500 SETOM CORLOK ;THE LOCK ...
07600 SETOM GLBPNT ;AND THE SWITCH SAYING INITED.
07700 MOVE THIS,TOP2 ;LAST ADDRESS IN SEC. SEG USED.
07800 ADDI THIS,1
07900 MOVEM THIS,LOWC(USER) ;SAVE FOR LATER
08000 PUSHJ P,NEWB2 ;AND LINK UP.
08100 JRST BUFRST ;ALL DONE INITIALIZING.
08200
08300 DSCR 2d SEGMENT CORE CONTROL STORAGE
08400 ⊗
08500
08600 CORLOK: 0
08700
08800 CR2BEG: BLOCK ZAPEND-ZAPBEG+1 ;AREA FOR ALL OTHERS.
08900
09000 ↑↑GLUSER←CR2BEG-ZAPBEG ;AND THE MAGIC INDEX.
09100 INTERNAL GLUSER
09200
09300 >;GLOB
09400
00100
00200 DSCR BUFRST
00300 CAL PUSHJ or JRST
00400 RES restores ACs from CORSER routines, and returns
00500 ⊗
00600
00700 BUFRST:
00800 IFN DEBCOR,<
00900 SKIPE PRTCOR ;SHOULD WE DEBUG?
01000 JFCL
01100 >
01200 MOVSI TEMP,BUFACS(USER)
01300 BLT TEMP,LAST
01400 POPJ P,
01500
01600 DSCR BUFSAV
01700 CAL PUSHJ
01800 RES Saves ACs for CORSER routine
01900 Initializes CORSER storage, obtains USER TABLE if GOGTAB is 0
02000 ⊗
02100
02200 BUFSAV:
02300 GLOB <
02400 SKIPN GLBPNT ;HAS GLOBAL MODEL BEEN INITIALIZED?
02500 PUSHJ P,CORE2I ;NO --INITIALIZE IT.
02600 >;GLOB
02700 SKIPE USER,GOGTAB ;CAN WE GO AHEAD?
02800 JRST JUSTSAVE ; YES
02900
03000 Comment ⊗ Use SALTAB and forget the rest if SALTAB is there. Otherwise
03100 set up a user table. Don't use THIS or SIZ (B or C). ⊗
03200
03300 NOEXPO <
03400 MOVEI TEMP,=76*=1024 ;ONE REALLY MUST KNOW WHAT HE
03500 >;NOEXPO
03600 EXPO <
03700 MOVEI TEMP,-1 ;FOR MAX CORE
03800 >;EXPO
03900 MOVEM TEMP,JOBFF ; IS DOING
04000
04100 ; SKIPE USER,SALTAB ;OTHERS CAN SPECIFY SAIL SPACE
04200 ; MOVEM USER,GOGTAB ;SET UP GOGTAB IF SALTAB NON-ZERO
04300 ; JUMPN USER,JUSTSAVE ;DON'T GO THRU SAIL's ALLOCATION
04400
04500 ; ASSUME THAT THE WORLD IS NEW
04600
04700 HLRZ USER,JOBSA ;USER TABLE ADDRESS
04800 MOVEM USER,GOGTAB ;THIS TIME FOR SURE
04900 SKIPN JOBDDT ;IF DDT IS IN CORE,
05000 JRST NODDT ; MAKE SURE ITS SYMBOLS ARE PROTECTED
05100 HRRZ TEMP,JOBSYM ;IF JOBSYM IS BELOW JOBFF, THEN
05200 CAML TEMP,USER ; ASSUME ALL SYMBOLS ARE BELOW.
05300 TERPRI <YOUR SYMBOLS ARE SOON TO BE OBLITERATED>
05400
05500
05600 NODDT: MOVEI TEMP,ENDREN-CLER+=2000(USER) ;MAKE SURE
05700 CAMGE TEMP,JOBREL ; ENOUGH CORE EXISTS
05800 JRST CORTHER ; FOR USER TABLE
05900
06000 CALL6 (TEMP,CORE) ;GET ENOUGH
06100 ERR <DRYROT -- NO ROOM FOR USER TABLE>
06200
06300 CORTHER:
06400 SETZM (USER) ;CLEAR USER TABLE
06500 HRL TEMP,USER
06600 HRRI TEMP,1(USER)
06700 BLT TEMP,ENDREN-CLER(USER)
06800 MOVEI THIS,ENDREN-CLER(USER) ;SET UP LIMITS OF FREE SPACE
06900 MOVEM THIS,LOWC(USER) ; BOTTOM
07000 PUSHJ P,NEWBLK ;MAKE NEW AREA INTO A FREE BLOCK
07100 JRST JUSTSAVE ;SAVE ACS
07200
07300 GLOB <
07400 NEWB2: CALLI LAST,SEGSIZUUO ;FIND OUT HOW BIG.
07500 TRO LAST,400000 ;SINCE ANDY DOES NOT GIVE ME THIS.
07600 JRST NEWB1
07700 >;GLOB
07800 NEWBLK:
07900 HRRZ LAST,JOBREL ;END OF BIG BLOCK
08000 NEWB1: SETZM (THIS) ;POINTERS WORD IN BIG BLOCK
08100 ADDI LAST,1 ;CONFORM TO "LAST" STANDARDS
08200 MOVEM LAST,TOP(USER) ;TOP OF FREE SPACE
08300 PUSH P,SIZ ;SAVE SIZE
08400 MOVE SIZ,LAST ;COMPUTE SIZE OF NEW BLOCK
08500 SUB SIZ,THIS ;SIZE OF BIG BLOCK
08600 PUSHJ P,RELINK ;PUT ON FREE STORAGE LIST
08700 POP P,SIZ ;GET SIZ BACK
08800 POPJ P,
08900
09000
09100 JUSTSAVE:
09200 MOVEI TEMP,BUFACS(USER)
09300 BLT TEMP,BUFACS+LAST(USER)
09400 IFN DEBCOR,<
09500 SKIPE PRTCOR ;SHOULD WE DEBUG?
09600 PUSHJ P,CORPRT ; YES
09700 >
09800 POPJ P,
09900
10000
10100 IFN DEBCOR,<
10200 ↑PRTCOR: 0
10300 >
00100 SUBTTL CORGET
00200
00300 DSCR CORGET
00400 CAL PUSHJ
00500 PAR size of desired block in AC C (3)
00600 RES SUCCESS: addr of block in B, skip-return
00700 FAILURE: no-skip
00800 SID none, except when called with GOGTAB 0 -- should only be done by experts
00900 DES a block of at least the required size is obtained using first-fit algorithm.
01000 Up to 10 extra words may be returned, but this is not reflected in C.
01100 ⊗
01200
01300 ↑CORGET:
01400 IFN DEBCOR,<
01500 SKIPE PRTCOR
01600 TERPRI <CORGET: > ;TELL THE PEOPLE WHO YOU ARE
01700 >
01800 PUSHJ P,BUFSAV ;SAVE AC'S, INITIALIZE WORLD PERHAPS
01900 GLOB <
02000 SKIPN USCOR2(USER) ;ARE WE INSTRUCTED TO USE CORE2?
02100 JRST COR21 ;NOPE -- GO AHEAD.
02200 ↑↑CORE2: SKIPN GLBPNT ;HAS IT BEEN INITIALIZED?
02300 PUSHJ P,CORE2I ;NO -- BUT NOW.
02400 AOSE CORLOK ;CAN WE GET THROUGH THE LOCK?
02500 JRST [SOS CORLOK ;APPARENTLY NOT.
02600 PUSHJ P,WAITQQ ;WAIT
02700 JRST .-1]
02800 MOVEI USER,GLUSER ;USE THIS VERSION OF USER.
02900 PUSHJ P,JUSTSAVE ;JUST SAVE THE ACCUMULATORS.
03000 >;GLOB
03100
03200
03300 COR21: ADDI SIZ,3 ;3 WORDS FOR CONTROL INFO
03400 SKIPE ATTOP(USER) ;IF USER REQUESTS IT, GET BLOCK
03500 JRST EXPAND ; AT TOP OF CORE
03600
03700 MOVEI THIS,FRELST(USER) ;THIS WILL POINT TO THE FIRST GOOD BLOCK
03800
03900 GETLUP: HRRZ THIS,(THIS) ;→NEXT FREE BLOCK
04000 JUMPE THIS,EXPAND ;TRY TO EXPAND CORE, NONE EXIST YET
04100 CAMLE SIZ,1(THIS) ;WILL IT FIT?
04200 JRST GETLUP ; NO, TRY NEXT
04300
04400 GETCOR: AOS (P) ;SUCCESS GUARANTEED
04500 HRRZM THIS,BUFACS+THIS(USER) ;RESULT(ALMOST)
04600 PUSHJ P,UNLINK ;UNLINK THIS BLOCK
04700 MOVE LAST,1(THIS) ;REAL BLOCK SIZE
04800 CAIGE LAST,TRIVIAL(SIZ) ;IS DIFFERENCE NEGLIGIBLE?
04900 JRST [MOVSI TEMP,400000 ;YES, USE WHOLE THING --
05000 ADD LAST,THIS ; MARK X-BIT TO INDICATE IN USE
05100 HLLM TEMP,-1(LAST)
05200 JRST GETOUT] ;AND GO FINISH OUT
05300
05400 MOVEM SIZ,1(THIS) ;NEW SIZE FOR RESULT
05500 HRRZ TEMP,THIS ;SAVE START OF BLOCK (RESULT)
05600 ADD THIS,SIZ ;NEW START FOR REMAINING FREE STUFF
05700 SUB LAST,SIZ ;NEW SIZE FOR REMAINS
05800 MOVE SIZ,LAST
05900 ADD LAST,THIS ;NEW END FOR REMAINS
06000 HRLI TEMP,400000 ;TURN X-BIT ON
06100 MOVEM TEMP,-1(THIS) ;IN USER'S BRAND NEW BLOCK
06200 PUSHJ P,RELINK ;RELINK REMAINS, RESTORE ACS
06300
06400
06500 GETOUT: PUSHJ P,GETRST ;RESTORE ACS
06600 SETZM (THIS) ;PTR RETRIEVED FROM STORAGE
06700 MOVNS 1(THIS) ;SIZE NEG ⊃ IN USE
06800 ADDI THIS,2 ;USER DOESN'T SEE THIS HEADER
06900 IFN DEBCOR,<
07000 SKIPE PRTCOR
07100 PUSHJ P,CORPRT
07200 >
07300 POPJ P, ;HERE'S YOUR BLOCK!
00100
00200 EXPAND: SKIPE XPAND(USER) ;IS IT ALLOWED TO EXPAND?
00300 JRST GETRST ; NO, ERROR RETURN
00400 PUSH P,SIZ ;SAVE TOTAL SIZE
00500 HRRZ THIS,TOP(USER) ;THIS→NEW BLOCK IF NEXT LOWER IS USED
00600 SKIPGE -1(THIS) ;IS TOP BLOCK FREE?
00700 JRST GETMOR ; NO, USE WHAT YOU HAVE
00800 HRRZ THIS,-1(THIS) ;UNLINK THE
00900 PUSHJ P,UNLINK ; TOP BLOCK
01000
01100 GETMOR: MOVE TEMP,THIS
01200 ADDI TEMP,=1024(SIZ) ;GET MORE AND THEN SOME
01300 POP P,SIZ ;GET THIS BACK BEFORE YOU FORGET
01400 GLOB <
01500 CAIN USER,GLUSER ;THIS IS HOW WE TELL
01600 JRST [CALLI TEMP,CORE2UUO ;GET SOME CORE
01700 JRST GETRST ;HE SPAT UPON OUR HUMBLE REQUEST.
01800 PUSHJ P,NEWB2 ;LINK IT UP
01900 JRST .+4]
02000 >;GLOB
02100 CALL6 (TEMP,CORE) ;ASK FOR MORE
02200 JRST GETRST ;CAN'T GET IT
02300 PUSHJ P,NEWBLK ;MAKE TOP LOOK LIKE FREE BLOCK
02400 CAMLE SIZ,1(THIS) ;NOW SHOULD FIT
02500 ERR <DRYROT -- EXPAND CODE GLUBBED UP>
02600 JRST GETCOR ;GO GET BLOCK
02700
02800 GETRST:
02900 GLOB <
03000 PUSHJ P,BUFRST ;RESTORE ACCUMULATORS.
03100 CAIN USER,GLUSER ;WAS IT CORE2?
03200 SOS CORLOK ;YES -- BACK UP COUNT.
03300 MOVE USER,GOGTAB ;RESET IT TO USUAL.
03400 POPJ P, ;
03500 >;GLOB
03600 JRST BUFRST
00100 SUBTTL CORINC, CANINC
00200
00300 DSCR CORINC
00400 CAL PUSHJ
00500 PAR AC B -- Addr of block to be incremented
00600 AC C -- amount if increase desired
00700 RES SUCCESS: skip-return, extra core has been granted
00800 FAILURE: no-skip
00900 SID none
01000 ⊗
01100
01200 ↑↑CORINC:
01300 IFN DEBCOR,<
01400 SKIPE PRTCOR
01500 TERPRI <CORINC:>
01600 >
01700 PUSHJ P,JUSTSAVE ;SAVE ACS
01800 MOVNI FF,1 ;WANT TO DO IT
01900 JRST INCR
02000
02100 DSCR CANINC
02200 CAL PUSHJ
02300 PAR same as CORINC
02400 RES No extra core is ever actually obtained
02500 if entire request can be granted, skip-return
02600 if some extra words available, no-skip, C contains possible increment
02700 if no extra words available, no-skip, C contains 0
02800 SID none except as described above
02900 ⊗
03000
03100 ↑↑CANINC:
03200 IFN DEBCOR,<
03300 SKIPE PRTCOR
03400 TERPRI <CANINC: >
03500 >
03600 PUSHJ P,BUFSAV
03700 MOVEI FF,0 ;JUST WANT TO SEE IF IT'S POSSIBLE
03800
03900 ; IF BLOCK IS AT TOP, CAN ALWAYS DO IT
04000
04100 INCR: SUBI THIS,2 ;POINT AT REAL BLOCK HEAD
04200 GLOB <
04300 TRNE THIS,400000 ;CHECK TO SEE IF CORE2
04400 ERR <NO CANINC SECOND SEGMENT SPACE>
04500 >;GLOB
04600 HRRZ LAST,THIS ;CHECK AT TOP
04700 SUB LAST,1(THIS) ; ADDR OF END (SIZE IS NEG)
04800 CAMGE LAST,TOP(USER) ;TOP BLOCK?
04900 JRST MIDDLE ; NO
05000 JUMPE FF,YESINC ;SUCCESS
05100 MOVNS 1(THIS) ;MAKE IT LOOK FREE
05200 ADD SIZ,1(THIS) ;TOTAL SIZE
05300 HRRZS -1(LAST) ;MAKE END LOOK FREE
05400 JRST EXPAND ;EXPAND AND RETURN
05500
05600 MIDDLE: SKIPGE TEMP,1(LAST) ;NEXT BLOCK FREE?
05700 JRST NONEATALL ; NO, FAILURE
05800 SUBI TEMP,3 ;AVAILABLE SIZE
05900 CAMLE SIZ,TEMP ;IS THERE ENOUGH?
06000 JRST MAYBE ; NO, FAILURE MAYBE
06100
06200 JUMPE FF,YESINC ;ALL OK, CAN DO, REPORT IT
06300 CRXXB: MOVNS TEMP,1(THIS) ;MAKE IT LOOK FREE
06400 PUSH P,(THIS) ;WILL RESTORE THIS IN CASE SOMEONE USED
06500 PUSH P,THIS ;SAVE SIZE
06600 PUSH P,SIZ ;AND POINTER
06700 ADDM TEMP,(P) ;TOTAL SIZE DESIRED AFTER RETURN
06800 MOVE SIZ,TEMP ;SIZE OF CURRENT "THIS"
06900 HRRZ THIS,LAST ;MERGE "THIS" WITH "LAST"
07000 PUSHJ P,UNLINK ;TAKE IT OFF FRELST
07100 ADD LAST,1(THIS) ;AND INCREASE
07200 ADD SIZ,1(THIS)
07300 MOVE THIS,-1(P) ;RETRIEVE CURRENT BLOCK.
07400 PUSHJ P,RELINK ;AND NOW RELINK ON FRELST.
07500 POP P,SIZ
07600 POP P,THIS
07700 PUSHJ P,GETCOR ;GET THE BLOCK AGAIN, ONLY BIGGER
07800 ERR <DRYROT> ;CAN'T HAPPEN
07900 POP P,-2(THIS) ;GET POINTER WORD BACK
08000 AOS (P) ;SUCCESS
08100 POPJ P, ;BUFRST DONE BY GETCOR
08200
08300 YESINC: AOS (P) ;REPORT SUCCESS
08400 IFN DEBCOR,<
08500 SKIPE PRTCOR
08600 PUSHJ P,CORPRT
08700 >
08800 JRST BUFRST
08900
09000 MAYBE: ADDI TEMP,3(LAST) ;GET TOP OF NEXT BLOCK AND SEE
09100 CAMGE TEMP,TOP(USER) ;IF IT IS THE TOP ONE.
09200 JRST NOTENUF ;NO -- FAIL UTTERLY.
09300 JUMPE FF,YESINC ;GOT IT IF ONLY GOING TO HERE.
09400 PUSH P,SIZ ;SAVE AMOUNT REQUESTED.
09500 MOVEI SIZ,-3(TEMP) ;THIS IS THE SIZE OF THE BLOCK WE
09600 SUB SIZ,LAST ;KNOW WE CAN GET.
09700 MOVN TEMP,SIZ
09800 ADDM TEMP,(P) ;(P) NOW HAS EXTRA REQUIRED.
09900 PUSHJ P,CRXXB ;AND WE DO SOO
10000 ERR <DRYROT> ; CAN'T HAPPEN.
10100 POP P,SIZ ;RETRIEVE SIZE.
10200 MOVNI FF,1 ;SINCE CRXXB DESTROYED IT.
10300 JRST INCR ;AND GO THROUGH AGAIN
10400 ;THIS TIME IT WILL BE THE TOP BLOCK.
10500
10600
10700 NOTENUF:
10800 SUBI TEMP,3(LAST) ;UNDO WHAT WAS DONE ABOVE
10900 SKIPA SIZ,TEMP ;CAN'T DO ALL, BUT CAN DO THIS MUCH
11000
11100 NONEATALL:
11200 MOVEI SIZ,0 ;CAN'T DO ANYTHING
11300 MOVEM SIZ,BUFACS+SIZ(USER)
11400 JRST BUFRST
11500
00100 SUBTTL CORREL
00200
00300 DSCR CORREL
00400 CAL PUSHJ
00500 PAR addr of block to be released in B
00600 RES block is released to free storage
00700 SID none
00800 DES the block is merged with any adjoining free blocks
00900 ⊗
01000
01100 ↑↑CORREL:
01200 IFN DEBCOR,<
01300 SKIPE PRTCOR
01400 TERPRI <CORREL: >
01500 >
01600 SKIPN USER,GOGTAB ;MUST BE SET UP HERE
01700 ERR <DRYROT -- CORREL CALLED WITH INITIALIZED WORLD>
01800 GLOB <
01900 TRNN THIS,400000 ;IS IT SECOND SEGMENT ADDRESS?
02000 JRST NOSGR ;NO
02100 MOVEI USER,GLUSER ;USE THIS ONE.
02200 AOSE CORLOK ;SEE IF WE CAN GET IN.
02300 JRST [SOS CORLOK
02400 PUSHJ P,WAITQQ
02500 JRST .-1]
02600 NOSGR:
02700 >;GLOB
02800 PUSHJ P,JUSTSAVE ;SAVE ACS
02900
03000 ; MERGE WITH LOWER NEIGHBOR (ADDRESS-WISE) IF POSSIBLE
03100
03200 SUBI THIS,2 ;USER THINKS IT STARTED 2 PAST
03300 MOVN SIZ,1(THIS) ;SIZE OF THIS BLOCK
03400 MOVE LAST,SIZ ;ADDRESS OF UPPER
03500 ADD LAST,THIS ; NEIGHBOR
03600
03700 CAMGE THIS,LOWC(USER) ;IS ADDRESS IN RANGE?
03800 ERR <DRYROT -- BAD ADDRESS TO CORREL>
03900 CAME THIS,LOWC(USER) ;CAN THERE BE A LOWER BLOCK
04000 SKIPGE -1(THIS) ; AND IF SO, IS IT FREE?
04100 JRST UPPET ; NO, LOOK FOR UPPER BLOCK
04200
04300 HRRZ THIS,-1(THIS) ;→LOWER BLOCK
04400 PUSHJ P,UNLINK ;UNLINK IT FROM LIST
04500 ADD SIZ,1(THIS) ;INCREASE SIZE
04600
04700 ; MERGE WITH UPPER NEIGHBOR IF POSSIBLE
04800
04900 UPPET: CAMLE LAST,TOP(USER)
05000 ERR <YOU ARE ABOUT TO GET AN ILL MEM-REF>,1
05100
05200 CAME LAST,TOP(USER) ;IS THERE AN UPPER BLOCK?
05300 SKIPGE 1(LAST) ;AND IF SO, IS IT FREE?
05400 JRST LNKRET ; NO, RELINK AND GO AWAY
05500
05600 UPPR: PUSH P,THIS
05700 HRRZ THIS,LAST ;THIS → UPPER NEIGHBOR
05800 PUSHJ P,UNLINK ;GET IT OUT
05900 ADD LAST,1(THIS) ; INCREASE EXTENT
06000 ADD SIZ,1(THIS) ; AND TOTAL SIZE
06100 POP P,THIS ; GET HEADER POINTER BACK
06200 LNKRET:
06300 GLOB <
06400 CAIN USER,GLUSER
06500 JRST LNKRT ;IF SEC SEGMENT, NEVER SHRINK
06600 >;GLOB
06700 ;;#IC# 7-3-72 DCS (1-1) ADD NEW MEANING TO NOSHRK(USER)
06800 SKIPL TEMP,NOSHRK(USER) ;If NOSHRK(USER) is:
06900 CAMG LAST,JOBREL ; <0, CORREL should not reduce core;
07000 JRST LNKRT ; >0, its RH indicates the amount of
07100 JUMPN TEMP,.+2 ; free space which should be
07200 MOVEI TEMP,=2046 ; protected from release;
07300 HRRZS TEMP ; =0, at least 2K should be protected.
07400 CAIGE TEMP,4 ;Only the first and third alternatives
07500 MOVEI TEMP,4 ; were previously available.
07600 CAMGE SIZ,TEMP ;Don't bother if there is already
07700 JRST LNKRT ; less free space available than
07800 ADDI TEMP,(THIS) ; desired
07900 ;;#IC# (1-1)
08000 CALL6 (TEMP,CORE)
08100 ERR <DRYROT --CORSER&LNKRET>
08200 MOVE LAST,JOBREL ; AND 2) ADJUST BLOCK TO INDICATE
08300 ADDI LAST,1
08400 MOVEM LAST,TOP(USER) ;AND RECORD NEW RESULTS.
08500 MOVE SIZ,LAST ; THE CHANGE BEFORE RELINKING
08600 SUB SIZ,THIS
08700 LNKRT:
08800 PUSHJ P,RELINK ;PUT IT BACK
08900 IFN DEBCOR,<
09000 SKIPE PRTCOR
09100 PUSHJ P,CORPRT
09200 >
09300 JRST GETRST ;AND GO AWAY
09400
00100 SUBTTL CORPRT, CORBIG
00200
00300 IFN DEBCOR,<
00400 ↑CORPRT:
00500 SETZM TOTFRE# ;TOTAL FREE STORAGE COUNT
00600 TERPRI <FREE STORAGE: >
00700 PUSH P,LPSA
00800 MOVE USER,GOGTAB ;THIS STUFF IS DEBUGGING
00900 MOVEI LPSA,FRELST(USER) ;JUNK FOR CORGET AND FRIENDS
01000
01100 CPLUP: HRRZ LPSA,(LPSA) ;IT SHOULD BE INTUITIVELY
01200 JUMPE LPSA,DUNNN ;OBVIOUS
01300 PRINT <START = >
01400 OCTPNT LPSA
01500 MOVE TEMP,1(LPSA)
01600 ADDM TEMP,TOTFRE
01700 PRINT < SIZE = >
01800 OCTPNT TEMP
01900 ADD TEMP,LPSA
02000 PRINT < END = >
02100 OCTPNT TEMP
02200 TERPRI
02300 JRST CPLUP
02400
02500 DUNNN:
02600 PRINT <TOTAL FREE SIZE = >
02700 OCTPNT TOTFRE
02800 SETOM PRTCOR
02900 TERPRI
03000 CAMLE THIS,JOBREL
03100 JRST DUNMOR
03200 TERPRI <THIS BLOCK: >
03300 PRINT <"THIS" = >
03400 MOVE TEMP,THIS
03500 OCTPNT TEMP
03600 PRINT < C-SIZE = >
03700 HRRZ TEMP,SIZ
03800 OCTPNT TEMP
03900 CAML THIS,JOBREL
04000 JRST DUNMOR
04100 HRREI LPSA,-2(THIS)
04200 JUMPLE LPSA,DUNMOR
04300 PRINT < BLOCK-SIZE = >
04400 MOVN TEMP,1(LPSA)
04500 OCTPNT TEMP
04600
04700 DUNMOR: TERPRI
04800 POP P,LPSA
04900 TTCALL 11,
05000 TTCALL TEMP
05100 TERPRI
05200 POPJ P,
05300
05400 >
05500
05600 DSCR CORBIG
05700 CAL PUSHJ
05800 PAR NONE
05900 RES LARGEST AVAILABLE BLOCK IN SIZ (3,C)
06000 SID THIS (2,B) MUNGED
06100 ⊗
06200
06300 ↑↑CORBIG: SKIPN USER,GOGTAB
06400 ERR <CORBIG: INITIALIZED WORLD>
06500 MOVEI SIZ,0 ;"ZERO-LENGTH" BLOCK
06600 MOVEI THIS,FRELST(USER)
06700 BIGLUP: HRRZ THIS,(THIS)
06800 JUMPE THIS,BIGDUN ;END OF FREELIST?
06900 CAMGE SIZ,1(THIS)
07000 MOVE SIZ,1(THIS) ;FIND MAX
07100 JRST BIGLUP
07200 BIGDUN: SUBI SIZ,3 ;WHAT HE SEES
07300 POPJ P,
07400
07500
07600
07700 Comment ⊗ No other core routines should be necessary to provide
07800 gross control over allocation. Programs obtaining
07900 space from CORGET can carve the blocks up if necessary.
08000 Please put your core back when you're done with it.
08100
08200 Thank You,
08300 The Management
08400
08500 ⊗
08600 >;NOLOW
08700 ENDCOM (COR)
08800 IFN ALWAYS,<
08900 BEND CORSER
09000 >
09100
09200 COMPIL(SGC,<STRNGC,STRGC,STCLER,SGINS,SGREM,%SPGC1,%ARSR1>
09300 ,<GOGTAB,X11,CORGET,CORREL,CORINC,X22,CORBIG,SPRPDA>
09400 ,<STRING GARBAGE COLLECTOR ROUTINES>
09500 ,<%SPGC,%STRMRK,%ARRSRT>)
00100 ;String Garbage Collector Routines
00200
00300 NOLOW < ;INCLUDE IN UPPER SEGMENT.
00400
00500 BKSZ←←=25 BKOFF←←=23 MLT←←5
00600
00700
00800 ↑.CORERR:
00900 ↑CORERR:
01000 ERR <NO CORE FOR ALLOCATION>
01100
01200 DSCR STRGC(# chars desired);
01300 CAL SAIL
01400 RES calls string garbage collector with #chars in -1(p)..i.e.a formal param.
01500 ⊗
01600
01700 HERE (STRGC)
01800 EXCH A,-1(P) ;THE DESIRED A IS HERE
01900 MOVE USER,GOGTAB
02000 MOVEM RF,RACS+RF(USER);SAVE F REGISTER WHERE GC CAN FIND.
02100 PUSHJ P,STRNGC ;COLLECT TRASH
02200 SUB P,X22 ;BACK UP STACK
02300 MOVNS A
02400 ADDM A,REMCHR(USER)
02500 MOVE A,1(P) ;GET ORIGINAL "A" BACK
02600 JRST 2,@2(P) ;RETURN
02700
02800
02900
03000 DSCR STRNGC
03100 CAL PUSHJ
03200 PAR A -- number of new characters needed
03300 REMCHR(USER) -- has been updated by that number of chars
03400 RES String space is compacted, new REMCHR is updated by C(A).
03500 Restarts if not enough room left
03600 SID none
03700 DES STRNGC is a two-pass process. In the first, all string descriptors
03800 are found and sorted into ascending sequence with respect to the locations
03900 of their respective texts. String descriptors are found via the generating
04000 routines, described in CALSG.
04100 In the second pass, all string texts are moved down to fill any
04200 unused space. All descriptors are adjusted to reflect the new locations.
04300 ⊗
04400
04500 ↑STRNGC: MOVE USER,GOGTAB ;GET USER TABLE POINTER
04600
04700 MOVEM 12,SGACS+12(USER)
04800 MOVEI 12,SGACS(USER)
04900 BLT 12,SGACS+11(USER)
05000
05100 ; →→→→→→ OBTAIN SPACE, INITIALIZE GARBAGE COLLECTOR ←←←←←←
05200
05300 HRRZ TEMP,TOPBYTE(USER) ;MAKE SURE DIDN'T OVERFLOW
05400
05500 ; **** BUG TRAP
05600 CAMG TEMP,STTOP(USER)
05700 CAMGE TEMP,ST(USER)
05800 ERR <DRYROT AT STRNGC>
05900 ; **** EBT
06000
06100 SUB TEMP,ST(USER) ;CREATE A DIVISOR FOR DISTRIBUTION
06200 ADDI TEMP,5 ; OF DESCRIPTORS DURING SGSORT
06300 MOVEM TEMP,INKY(USER)
06400 SKIPE XPAND(USER) ;ALLOWED TO EXPAND?
06500 JRST INSIDE ; NO
06600 SETOM ATTOP(USER) ;WANT BLOCK OFF THE TOP FOR SAFETY
06700 MOVEI C,=400 ;REASONABLE SIZE
06800 PUSHJ P,CORGET ;IF CAN'T GET IT, TROUBLE
06900 SKIPA ;TRY TO GET WHAT YOU CAN
07000 JRST CORROK ;GOT IT
07100 INSIDE: SETZM ATTOP(USER) ;CAN'T EXPAND
07200 PUSHJ P,CORBIG ;HOW MUCH CAN WE HAVE?
07300 PUSHJ P,CORGET ;GET THAT AMOUNT
07400 ERR <DRYROT - STRNGC CAN'T GET CORE>
07500 CORROK: SETZM ATTOP(USER) ;NOW CAN GET ANYWHERE
07600 MOVEM B,STBUCK(USER) ;SAVE → TO BLOCK
07700 SETZM (B)
07800 HRLS B
07900 ADDI B,1
08000 MOVEI TEMP,BKOFF(B)
08100 BLT B,(TEMP)
08200 MOVE B,STBUCK(USER)
08300 ADDI B,BKSZ ;FIRST BKSZ WORDS IS "BUCKET" LIST
08400 MOVNI C,-BKSZ(C)
08500 JUMPGE C,CORERR ;BAD THING
08600 HRL B,C
08700 SUB B,X11 ;IOWD FOR WORD ALLOC IN STRNGC
08800 MOVEM B,SGFRE(USER) ;FREE SPACE POINTER
08900
09000 HRRZ A,ST(USER)
09100 HRLI A,(<POINT 7,0>)
09200 MOVEM A,TOPBYTE(USER) ;FIRST(USER) NEW OK POSITION
09300 SETZM NUMCHR(USER) ;TOTAL # CHARS PREVIOUSLY MOVED
00100
00200 ; →→→→→→ SORT THE STRINGS ←←←←←←←←←
00300 DSCR CALSG
00400 PAR linked list of routine addresses based at SGROUT(USER)
00500 RES each routine in list is called to provide string descriptors
00600 to the sorting routine, SGSORT.
00700 SID SGSORT uses B,C,D,E,TEMP, accepts input in A. Generating
00800 routines may use A-T1 (12) and TEMP for their own devices.
00900 Q1 through T1 will not be changed by calls on SGSORT.
01000 DES Each generating routine should do the following:
01100 1) Place a string descriptor in A
01200 2) PUSHJ P,SGSORT or PUSHJ P,@-1(P) (addr provided on stack)
01300 3) Repeat the process if it knows about more strings, else return
01400 4) Return with a POPJ (and a flourish)
01500
01600 The `standard' generating routines are:
01700 SPSG -- collects the string stack
01800 STRMRK -- collects string variables linked through SGLINK(USER)
01900 ARRMRK -- collects string arrays found in ARRPDL
02000 RINGSORT -- collects PNAMES from semantic blocks in compiler
02100 DEFSRT -- collects saved input strings during macro recursion in compiller
02200 These routines should provide sufficient examples.
02300
02400 ⊗
02500
02600
02700 CALSG: MOVEI T,SGROUT(USER) ;GET LINKED LIST OF ROUTINE NAMES
02800 PUSH P,T ;SAVE FIRST POINTER
02900 PUSH P,[SGSORT] ;PROVIDE ACCESS TO SORTING ROUTINE
03000 ↑CALSGL:
03100 SKIPN T,@-1(P) ;GO DOWN LIST UNTIL DONE
03200 JRST ALLCOL ;DONE
03300 HRRZM T,-1(P) ;SAVE NEW POINTER
03400 PUSHJ P,@-1(T) ;CALL GENERATOR ROUTINE
03500 JRST CALSGL ;DO MORE THAN ONCE
03600
00100
00200 ; →→→→→→ SORT THE SP STACK ←←←←←←
00300
00400 HERE(%SPGC) HRRZ A,SPDL(USER) ;START AT BASE OF STACK
00500 ↑%SPGC1:ADDI A,1
00600 JRST SGTST ;AND WORK UP TO CURRENT POINTER
00700 STRNGSTACKMARKLOOP:
00800 PUSHJ P,SGSORT ;SORT IT INTO LIST
00900 SGTST:
01000 CAIGE A,(SP) ;DONE?
01100 JRST STRNGSTACKMARKLOOP ;NO
01200 GPOPJ: POPJ P, ;YES, GO ON TO NEXT TYPE
01300
01400 ; →→→→→→ SAIL COMPILER SPECIAL SORTERS ARE IN COMSER ←←←←←
01500
01600 ; →→→→→→ SORT THE VARIABLES ←←←←←←
01700
01800 HERE (%STRMRK)
01900 SKIPN T,STRLNK(USER) ;GET LINK
02000 POPJ P, ; NO STRINGS AT ALL
02100 STMKL1: HRRZ A,-1(T) ;→1ST STRING
02200 HLRZ Q2,-1(T) ;# STRINGS THIS PROC
02300 JRST SOJLP ;GO LOOP
02400 STMKLP:
02500 ; SKIPN -2(T) ;PROCEDURE ACTIVE?
02600 ; SETZM (A) ; NO, MAKE NULL STRINGS
02700
02800 Comment ⊗ Due to certain social pressures (WFW LIVES ON)
02900 strings in inactive blocks remain over garbage collection ⊗
03000
03100 PUSHJ P,SGSORT ;SORT VARIABLES INTO LIST
03200 SOJLP: SOJGE Q2,STMKLP ;SORT UNTIL DONE WITH THIS PROC (SGSORT INCRS A)
03300
03400 STRMK4: HRRZ T,(T) ;NEXT PROCEDURE
03500 JUMPN T,STMKL1 ; IF THERE IS ONE
03600 POPJ P, ;DONE
03700
03800
03900 COMMENT ⊗
04000 →→→→→→ SORT STRING ARRAYS ←←←←←←
04100
04200
04300 THIS ROUTINE TRIPS DOWN THE DYNAMIC LINKS, LOOKING INTO
04400 PROCEDURE DESCRIPTORS FOR STRING ARRAYS WHICH MIGHT HAVE BEEN ALLOCATED.
04500 THEN IT LOOKS FOR ANY ARRAYS OWNED BY LEAP. THE FIRST
04600 WORD OF EACH ARRAY BLOCK IS THE NUMBER OF DIMENSIONS IF THE
04700 ARRAY IS A STRING ARRAY. THE WORD JUST PREVIOUS TO IT IS THE
04800 (NEGATIVE) SIZE OF THE ARRAY.
04900 ⊗
05000
05100 INTERNAL %ARRSRT
05200 HERE (%ARRSRT)
05300 HRRZ RF,RACS+RF(USER);REAL RF WITH LH= 0
05400 ↑%ARSR1:
05500 PROCDO: HLRZ Q1,1(RF) ;FETCH PDA
05600 CAIN Q1,SPRPDA ;IS IT SPROUTER??
05700 POPJ P, ;YES
05800 MOVE Q1,PD.LLW(Q1) ;WE HAVE TO DO SOMETHING -- PT AT LVI
05900 CHK: SKIPN T,(Q1) ;GET ENTRY
06000 JRST GODOWN ;0 MEANS OF PROC DESCR
06100 ;;#HI#↓ 5-15-72 DCS WAS TESTING 200000 (TYPE 4?) BIT, WRONG BIT!
06200 TLC T,100000 ;TYPE 2? (STRING ARRAY)
06300 TLNE T,740000 ;
06400 AOJA Q1,CHK ;NO
06500 SKIPN A,@T ;THERE??
06600 AOJA Q1,CHK ;NO
06700 ;;# # 5-3-72 DCS
06800 SUBI A,1 ;A→2D WORD, FIRST ENTRY -- DCS 5-3-72
06900 ;;# #
07000 SKIPL Q2,-1(A) ;BETTER BE THERE
07100 ERR <DRYROT AT ARRSRT>
07200 PUSHJ P,ARPUTX ;GO SORT IT
07300 AOJA Q1,CHK
07400
07500 GODOWN: HRRZ RF,(RF) ;NOTE THAT RESTR WILL PUT RF BACK
07600 CAIE RF,-1 ;
07700 JRST PROCDO ;-1 WILL SAY END
07800
07900
08000 LARR: SKIPN T1,ARYLS(USER) ;LEAPING LISTS
08100 POPJ P, ;NONE
08200 LAR1:
08300 HLRZ Q2,(T1) ;GET ADDRESS
08400 ;;# # 5-3-72 DCS SET UP A
08500 MOVEI A,-1(Q2) ;A→1ST WORD, FIRST ENTRY
08600 ;;# #
08700 SKIPL Q2,-2(Q2) ;BE SURE
08800 ERR <LEAPING DRYROT AT ARRSRT>
08900 PUSHJ P,ARPUTX ;GO SORT IT
09000
09100 LAR2: HRRZ T1,(T1) ;MERRILY WE LINK ALONG
09200 JUMPN T1,LAR1 ;
09300 POPJ P, ;HOME AT LAST
09400
09500 ARPUTX:
09600 HRRZS Q2 ;YES, GET TOTAL SIZE
09700 LSH Q2,-1 ;NUMBER OF STRINGS
09800
09900 JRST ARSLP
10000
10100
10200 ARS3:
10300 PUSHJ P,SGSORT ; BUT COLLECT NON-CONSTANTS
10400 ARSLP: SOJGE Q2,ARS3 ;A INCREMENTED IN SGSORT, LOOP UNTIL DONE
10500 POPJ P, ;ALL DONE WITH THIS ARRAY.
00100
00200 ; SUBROUTINE ENTERED WITH A → A STRING DESCRIPTOR. CONVERTS
00300 ; IT TO GARBAGE COLLECTOR FORMAT. USES B, C.D,E,TEMP
00400 ; START CONTAINS FIRST #CHARS FOR BEGINNING OF STRING SPACE.
00500 ; WARNING ***** CLOBBERS B,C,D,E,TEMX **********
00600
00700 SGSORT:
00800
00900 HLLZ B,(A) ;GET STRING NUMBER
01000 JUMPE B,SGSRT ; DON'T COLLECT CONSTANTS OR NULL STRINGS
01100
01200 HRRZ D,1(A) ;MAKE SURE STRING IN RANGE
01300 HRRE C,(A) ;CHECK LENGTH CONSISTENCY
01400
01500 ; *** BUG TRAP
01600 JUMPE C,DONBUG ;DON'T WORRY MUCH ABOUT NULL STRINGS
01700 JUMPL C,BUGG
01800 CAMG D,STTOP(USER)
01900 CAMGE D,ST(USER)
02000 BUGG: ERR <DRYROT AT SGSORT>,1
02100 DONBUG:
02200 ; *** EBT
02300
02400 HLLZ B,1(A) ;GET POINTER AND SIZE FIELDS OF BP
02500 HRRI B,[BYTE (7) 0,1,2,3,4,5]
02600 ILDB B,B ;#CHARS REPRESENTED BY POINTER
02700 ;C HAS ADDR FILED OF BP (SEE ABOVE)
02800 SUB D,ST(USER) ; - STRING SPACE BASE
02900 IMULI D,5 ;#CHARS
03000 ADD B,D ; + CHARS IN POINTER
03100 MOVEM B,1(A) ; TO BP WORD
03200 ADD C,B ; + #CHARS FIELD (D LOADED ABOVE)
03300 ;RLS PATCH -- ALLOW MORE THAN 52000 WORDS OF STRING!SPACE
03400 ; HRRZM C,(A) ;TO #CHARS WORD
03500 MOVEM C,(A) ;TO #CHARS WORD
03600 MOVE D,B ;NOW DISTRIBUTE STRING TO PROPER
03700 IMULI D,MLT ; LIST TO SPEED SORT
03800 IDIV D,INKY(USER) ; SEE ABOVE FOR INKY CALC
03900 ADD D,STBUCK(USER) ;D→PROPER "BUCKET" ENTRY
04000
04100 ; *** BUG TRAP
04200 MOVE TEMP,STBUCK(USER)
04300 CAML D,TEMP
04400 CAIL D,BKSZ(TEMP)
04500 ERR <DRYROT AT SGSLUP>,1
04600 ; *** EBT
04700
04800
04900 ; A→ STRING DESCRIPTOR (MARKED) -- D→BUCKET LIST THIS STRING
05000 ; B IS START COUNT [=1(A)] -- C IS END COUNT [=(A)]
05100
05200 SGSLUP: MOVE E,D ;E←CDR(E), IN FACT
05300 HRRZ D,(E) ;D←CDR(E)
05400 SKIPN D ;DONE?
05500 JRST INSERT ; YES, INSERT AT END
05600 HLRZ TEMP,(D) ;TEMP←CAR(D)
05700 CAMGE B,1(TEMP) ;NEW START LESS?
05800 JRST INSERT ;YES, INSERT THIS ONE IN FRONT OF IT
05900 CAME B,1(TEMP) ;NEW START SAME?
06000 JRST SGSLUP ;NO, GREATER
06100
06200 ; EQUAL START COUNTS, ARRANGE BY END COUNT, DESCENDING SEQUENCE
06300
06400 CAMG C,(TEMP) ;NEW END GT OLD?
06500 JRST SGSLUP ;NO, CONTINUE
06600 ; (JRST INSERT) ;YES
06700
06800 INSERT:
06900 MOVE TEMP,SGFRE(USER)
07000 AOBJN TEMP,STILMOR ;EXPAND LINK SPACE
07100 SGXPND:
07200 PUSH P,TEMP
07300 MOVE B,STBUCK(USER) ;→CURRENT FWS BLOCK
07400 MOVEI C,=100 ;GET 100 MORE
07500 PUSHJ P,CORINC ;EXPAND THE BLOCK
07600 ERR <NO CORE FOR ALLOCATION>
07700 POP P,TEMP
07800 SUB TEMP,[(100)] ;THERE IS MORE
07900
08000 STILMOR:
08100 MOVEM TEMP,SGFRE(USER)
08200 HRLM A,(TEMP)
08300 HRRM D,(TEMP)
08400 HRRM TEMP,(E)
08500 SGSRT: ADDI A,2 ;AUTO-INDEXING
08600 POPJ P,
00100
00200 ; FIND A DISJOINT STRING GROUP, MOVE IT BACK.
00300 ; MARK POINTERS APPROPRIATELY.
00400
00500 ALLCOL: SUB P,X22 ;REMOVE JUNK PUT ON BY CALSG
00600
00700 SGSWEP:
00800 SETZB T,T1 ;IN CASE NO STRINGS AT ALL
00900 MOVEI Q2,1 ;INIT STRING NO.
01000 MOVE Q3,STBUCK(USER) ;WORK UP BUCKET LIST, HANDLING
01100 MOVEI FF,BKSZ(Q3) ;EVERYTHING IN THE PATH
01200 SUBI Q3,1
01300 PUSHJ P,FSTSTR ;A→FIRST LIST
01400 HLRZ Q1,(A) ;Q1 → FIRST MARKED DESCRIPTOR
01500 JRST SGFX1 ;JUMP INTO THINGS
01600
01700 SGFIX: PUSHJ P,NXTSTR ;A→NEXT LIST ELEMENT
01800 HLRZ Q1,(A) ;Q1 → NEXT DESCRIPTOR
01900 CAMG T1,1(Q1) ;INCLUDED IN OR OVERLAPPING THIS STRING
02000 JRST SGBLT ; NO, MOVE OLD BEFORE HANDLING NEW
02100 PUSHJ P,FIXPTR ;FIX UP DESCRIPTOR
02200 CAMGE T1,TEMP ;OVERLAPPING STRING
02300 MOVE T1,TEMP ; YES, USE BIGGER END POINT
02400 JRST SGFIX ;CONTINUE
02500
02600 SGBLT: ADDI Q2,1 ;INCREMENT STRING NUMBER
02700 MOVN B,T
02800 ADD B,T1 ;TOTAL STRING SIZE
02900 SKIPN SGLIGN(USER) ;HAVE TO ALIGN TO FW BDRY?
03000 JRST NOLIGN ; NO
03100 ADDI B,4 ;YES, DO IT
03200 IDIVI B,5
03300 IMULI B,5 ;NOW MULT OF 5 CHARS, BIG ENOUGH
03400 NOLIGN:
03500 ADDM B,NUMCHR(USER) ;NUMBER USED SO FAR
03600 MOVE C,T ;STARTING COUNT FOR STRING
03700 PUSHJ P,MKBPT ;PICK UP FROM HERE
03800 MOVE T,TOPBYTE(USER) ;PUT DOWN HERE
03900 JUMPE B,SGBLT1 ;DON'T DO IT IF NOT NECESSARY
04000 BLTLUP: ILDB D,C
04100 IDPB D,T ;WHEEE!
04200 SOJG B,BLTLUP ;MOVE 'EM ON OUT
04300 MOVEM T,TOPBYTE(USER) ;RESTORE IT
04400
04500 SGBLT1: JUMPE A,STSTAT ;LAST ONE
04600 SGFX1: MOVE T,1(Q1) ;INITIALIZE START OF STRING,
04700 MOVE T1,(Q1) ; END OF STRING,
04800 MOVE E,T ; OFFSET FOR BP FIXUPS
04900 SUB E,NUMCHR(USER) ; (THIS IS THE OFFSET)
05000 PUSHJ P,FIXPTR ;FIX UP THIS DESCRIPTOR
05100 JRST SGFIX ;CONTINUE
05200
05300 NXTSTR: HRRZ A,(A) ;A←CDR(A)
05400 JUMPN A,APOPJ ; GOT ONE, DONE
05500 FSTSTR: AOS A,Q3 ;END OF THAT LIST, LOOK AT NEXT
05600 CAMGE A,FF ;OOOPS, THERE ARE NO MORE!
05700 JRST NXTSTR ; YES THERE ARE
05800 SUB P,X11 ;DON'T RETURN, BUT MARK DONE,
05900 MOVEI A,0 ; AND GO OFF FOR LAST
06000 JRST SGBLT ; NOSTALGIC MOVE
06100
06200 FIXPTR: MOVE TEMP,(Q1)
06300 SUB TEMP,1(Q1) ;SIZE OF STRING FOR THIS DESCRIPTOR
06400 HRL TEMP,Q2 ;ADD STRING NUMBER
06500 EXCH TEMP,(Q1) ;PUT FIRST WORD AWAY
06600 MOVE C,1(Q1) ;START COUNT
06700 SUB C,E ;ADJUST TO NEW LOCATION
06800 PUSHJ P,MKBPT ;MAKE A BYTE POINTER
06900 MOVEM C,1(Q1) ;THIS BABY IS READY TO FLY!
07000 APOPJ: POPJ P, ;ALL DONE
07100
07200 ; MKBPT TAKES A #CHARS IN C, MAKES A BYTE POINTER RELATIVE TO ST
07300 ; OUT OF IT, LEAVES IT IN C -- DESTROYS D
07400
07500 MKBPT: IDIVI C,5 ;WORD # IN C, CHAR OFLOW IN D
07600 ADD C,ST(USER) ;REAL WORD #
07700 HLL C,[POINT 7,0
07800 POINT 7,0,6
07900 POINT 7,0,13
08000 POINT 7,0,20
08100 POINT 7,0,27](D) ;POINTER PART
08200 POPJ P,
00100
00200 ; FINISH UP
00300
00400 STSTAT:
00500 SKIPN SGLIGN(USER) ;HAVE TO LINE UP TOPBYTE?
00600 JRST NORCLR ;NO
00700 MOVE C,T1 ;END CHAR # OF LAST STRING
00800 SUB C,E ;ADJUST BY THE WINNING OFFSET
00900 PUSHJ P,MKBPT ;MAKE A BP FOR TO BE TOPBYTE
01000 MOVEM C,TOPBYTE(USER) ;FOR THE RIDICULOUS, DEMANDING SAIL
01100 PUSHJ P,RESCLR ;CLEAR REST OF STRING SPACE
01200 ;;#GI# DCS 2-5-72 REMOVE TOPSTR
01300 NORCLR: AOS SGCCNT(USER)
01400 MOVN B,STMAX(USER)
01500 IMULI B,5
01600 ADD B,NUMCHR(USER)
01700 ;;#GI# DCS 2-2-72 (2-3) LEAVE SOME SLOP SO ONE NEEDN'T FEAR INSET
01800 ADDI B,=15 ;SOME SLOP
01900 ADD B,SGACS+A(USER) ;#CHARS WHICH CAUSED THIS MESS IN FIRST PLACE
02000 MOVEM B,REMCHR(USER)
02100 ;;#GI (2-3)
02200 JUMPGE B,[ERR (<STRING SPACE EXHAUSTED, WILL RESTART>,1)
02300 JRST @JOBREN] ;RE-ALLOCATE
02400 MOVE B,STBUCK(USER) ;RELEASE IT
02500 PUSHJ P,CORREL
02600 HRLZI 12,SGACS(USER)
02700 BLT 12,12
02800 POPJ P,
02900
00100
00200 COMMENT ⊗Sgins, Sgrem ⊗
00300
00400 DSCR SGINS
00500 CAL PUSHJ
00600 PAR PUSH P,[routine name]
00700 PUSH P,[addr of 2-word block]
00800 RES block is used to place routine in the list of descriptor generators
00900 for CALSG.
01000 SID stack adjusted
01100 ⊗
01200
01300 ↑↑SGINS:
01400 PUSH P,-2(P) ;ADDR OF ROUTINE
01500 PUSHJ P,SGREM ;NEVER LET IT BE IN TWICE
01600 MOVE USER,GOGTAB
01700 POP P,UUO1(USER)
01800 POP P,LPSA ;→LINK BLOCK FOR NEW ROUTINE
01900 POP P,-1(LPSA) ;PUT ROUTINE ADDRESS AWAY
02000 HRL LPSA,SGROUT(USER);GET OLD LINK POINTER
02100 HLRM LPSA,(LPSA) ;PUT IN NEW LINK POSITION
02200 HRRM LPSA,SGROUT(USER);PUT NEW POINTER IN LINK HEAD
02300 JRST @3(P) ;RETURN
02400
02500 DSCR SGREM
02600 CAL PUSHJ
02700 PAR PUSH P,[routine addr]
02800 RES routine is removed from list of descriptor generators, if it was on it
02900 ⊗
03000
03100 ↑↑SGREM:
03200 MOVE USER,GOGTAB
03300 POP P,UUO1(USER)
03400 POP P,TEMP ;ADDR TO BE REMOVED
03500 MOVEI LPSA,SGROUT(USER);HEAD OF LIST
03600 SGRL: MOVE USER,LPSA ;PREV←THIS
03700 SKIPN LPSA,(USER) ;THIS←(PREV)
03800 JRST @2(P) ;DIDN'T FIND IT
03900 CAME TEMP,-1(LPSA) ;IS THIS THE ROUTINE?
04000 JRST SGRL ;NO, GET NEXT
04100 HRRZ TEMP,(LPSA) ;YES, REMOVE IT FROM LIST
04200 HRRM TEMP,(USER)
04300 JRST @2(P)
04400
00100
00200 DSCR STCLER
00300 CAL PUSHJ
00400 RES Clears all string variables on STRLNK(USER) to null strings
00500 DES compiler only
00600 ⊗
00700
00800 ↑STCLER:
00900 SKIPE SGLIGN(USER) ;CLEAR REST?
01000 PUSHJ P,RESCLR ;CLEAR REST OF STRING SPACE
01100 SKIPN T,STRLNK(USER) ;PARALLELS STRNGC'S LOOP
01200 POPJ P, ;CLOSELY
01300 PUSH P,B ;JUST IN CASE
01400 HRLZI B,-1 ;FOR TESTING STRING NO.
01500 STC1: HRRZ A,-1(T)
01600 HLRZ Q2,-1(T)
01700 STCLLP: SOJL Q2,STCLD1
01800 TDNE B,(A) ;DON'T COLLECT STRING CONSTANTS
01900 SETZM (A)
02000 ADDI A,2
02100 JRST STCLLP
02200 STCLD1: ;SETZM -2(T) ;***** CAN'T DO THIS UNLESS PATSW IS
02300 ; *** ON IN COMPILER!!!!!
02400 HRRZ T,(T)
02500 JUMPN T,STC1
02600 POP P,B
02700 POPJ P,
02800
02900 DSCR RESCLR
03000 CAL PUSHJ
03100 DES Used after STRNGC. Clears remaining string space to 0 (compiler only)
03200 ⊗
03300 RESCLR: SKIPL A,TOPBYTE(USER) ;CAN ZERO FIRST WORD IF 440700
03400 ADDI A,1 ;ELSE START AT NEXT
03500 SETZM (A)
03600 HRLS A
03700 ADDI A,1 ;BLT WORD
03800 MOVE B,STTOP(USER) ;END OF STRING SPACE
03900 BLT A,-1(B) ;ZERO!!
04000 POPJ P,
04100
04200 INTERNAL BRKMSK
04300 ↑BRKMSK: 0
04400 FOR @& JJ←=17,0,-1 <
04500 <1 ⊗ (JJ+=18)> + (1 ⊗ JJ)>
04600 >;NOLOW
04700 ENDCOM (SGC)
04800 IFN ALWAYS,<
04900 NOLOW <
05000 ↑CORGET←CORGET
05100 >;NOLOW
05200 >;IFN ALWAYS
05300 SUBTTL GOGOL
00100 SUBTTL Some Runtime Routines Which Could Go Nowhere Else
00200
00300 DSCR BEGIN GOGOL
00400 DES RUN-TIME ROUTINES WILL BE DESCRIBED BY SAIL MANUAL CALLING SEQUENCES ONLY
00500 ⊗
00600 NOLOW <
00700 IFN ALWAYS,<BEGIN GOGOL>
00800 >;NOLOW
00900 COMPIL(KNT,<K.ZERO,K.OUT>,<GETCHAN,GOGTAB>
01000 ,<K.ZERO, K.OUT -- PERFORMANCE COUNTING ROUTINES>)
00100 COMMENT ⊗ Kounter Routines⊗
00200 DSCR K.ZERO -- Zero out counters
00300 CAL PUSHJ P,K.ZERO
00400 RES The counter arrays of the sail program loaded are set to zero.
00500 K.ZERO determines the location of the counter blocks via the loader
00600 link chain (5) whose head is in the location KNTLNK(USER). If there
00700 are no counters, the routine is essentially a NO-OP. SID All
00800 registers used by K.ZERO are saved on entry and restored on exit. SEE
00900 K.OUT
01000 ⊗
01100
01200 HERE(K.ZERO)
01300 PUSH P,2 ;SAVE REGISTER 2
01400 MOVE USER,GOGTAB
01500 SKIPN 2,KNTLNK(USER) ;GET LINK TO COUNTERSS
01600 JRST K.ZR2 ;THERE ARE NONE
01700 PUSH P,3 ;SAVE OTHER REGS NEEDED
01800 PUSH P,4
01900 PUSH P,5
02000 K.Z1: MOVE 3,2(2) ;GET SECOND IOWD OF HEADER BLOCK
02100 MOVEI 4,2(3) ;GET <.KOUNT+1>
02200 HRLI 4,-1(4) ;GET READY FOR BLT
02300 HLRO 5,3 ;GET -COUNT
02400 MOVN 5,5 ;MAKE THAT +COUNT
02500 HRLI 5,3 ;PUT AN INDEX FIELD OF 3
02600 SETZM -1(4) ;ZERO THE FIRST COUNTER
02700 BLT 4,@5 ;ZERO THE REST
02800 SKIPE 2,(2) ;GET THE NEXT SET OF COUNTERS
02900 JRST K.Z1 ;ZERO THEM
03000 POP P,5 ;RESTORE THE REGISTERS
03100 POP P,4
03200 POP P,3
03300 K.ZR2: POP P,2
03400 POPJ P, ;RETURN
00100
00200 DSCR K.OUT -- Write out counters
00300 CAL PUSHJ P,K.OUT
00400 RES The values of the statement counters are written out to the
00500 disk. The IOWDs used to write them are also written out in
00600 order to be able to know how many to read back in. The filename
00700 is obtained from the header block of the first program loaded.
00800 The data blocks have the following form:
00900
01000 --------------------------
01100 | SIXBIT /FILNAM/ |
01200 --------------------------
01300 | LINK to other blocks |
01400 --------------------------
01500 | IOWD 1,.+1 |
01600 --------------------------
01700 | IOWD n,.KOUNT |
01800 --------------------------
01900 | 0 |
02000 --------------------------
02100 .KOUNT: | 1st counter |
02200 --------------------------
02300 | . . . |
02400
02500 | . . . |
02600 --------------------------
02700 | nth counter |
02800 --------------------------
02900
03000 SID No registers are permanently modified.
03100 ⊗
03200 HERE(K.OUT)
03300 MOVE USER,GOGTAB
03400 SKIPN KNTLNK(USER) ;ARE THERE ANY COUNTERS
03500 POPJ P, ;NO
03600
03700
03800 COMMENT ⊗ First save registers 0-16
03900 ⊗
04000
04100 MOVEM 16,17(P) ;SAVE IN THE STACK
04200 MOVEI 16,1(P) ;GET READY TO STORE 0-15
04300 BLT 16,16(P) ;DO IT
04400 ADD P,[XWD 17,17] ;ADJUST STACK POINTER
04500 TLNN P,400000 ;CHECK FOR OVERFLOW
04600 ERR <PDL overflow in K.OUT routine>
04700
04800
04900 COMMENT ⊗ Before the counters can be written out, it
05000 is necessary to chain the blocks together in the
05100 proper direction. Recall that there will be multiple
05200 blocks only if the core image is the result of loading
05300 multiple compilatons.
05400 ⊗
05500
05600 MOVE 2,KNTLNK(USER) ;GET LINK TO LAST BLOCK
05700 SKIPN 1,(2) ;GET LINK TO PREV.
05800 JRST .+5 ;THAT'S ALL
05900 MOVEI 0,1(2) ;GET ADDR OF 1st IOWD OF THIS BLOCK
06000 MOVEM 0,3(1) ;STORE BELOW 2nd IOQS OF PREV BLOCK
06100 MOVE 2,1 ;CONTINUE
06200 JRST .-5
06300
06400
06500 COMMENT ⊗ At this point, 1(2) contains the start of a dump
06600 mode command chain that will write out all of the counters.
06700 -1(2) contains the filename for the counter file.
06800 ⊗
06900
07000 PUSHJ P,GETCHAN ;GET AN AVAILABLE CHANNEL
07100 JUMPL 1,K.OERR ;NONE AVAILABLE
07200 MOVE 0,[XWD K.OD1,3] ;MOVE CODE TO REGISTERS
07300 BLT 0,16 ;SO THAT IT CAN BE SAFELY MODIFIED
07400 DPB 1,[POINT 4,3,12] ;STORE CHANNEL NUMBER IN OPEN INSTR
07500 DPB 1,[POINT 4,5,12] ;STORE CHANNEL NUMBER IN ENTER INSTR
07600 MOVE 10,-1(2) ;PICK UP FILE NAME
07700 JRST 3 ;OPEN AND ENTER,HOPEFULLY RETURNING TO .+1
07800 K.O1: MOVE 0,[XWD K.OD2,3] ;DO IT AGAIN
07900 BLT 0,7
08000 DPB 1,[POINT 4,3,12] ;OUT INSTRUCTION
08100 DPB 1,[POINT 4,6,12] ;RELEAS INSTRUCTION
08200 JRST 3
08300
08400
08500 COMMENT ⊗ The counters have been written out to the disk. It's
08600 time to restore the registers and go home.
08700 ⊗
08800
08900 K.O2: MOVSI 16,-16(P) ;PREPARE TO RESTORE REGS
09000 BLT 16,16 ; FROM THE STACK
09100 SUB P,[XWD 17,17] ;ADJUST STACK POINTER
09200 POPJ P, ;RETURN
09300
09400 K.OERR: IOERR <I/O error in writing counter file>
09500
09600
09700 COMMENT ⊗ The following instructions are moved into
09800 registers before they are executed, since the "channel"
09900 portion of them must be modified at run time.
10000 ⊗
10100
10200 K.OD1: OPEN 0,14 ;(3) OPEN DISK ON SPECIFIED CHANNEL
10300 JRST K.OERR ;(4) TROUBLE
10400 ENTER 0,10 ;(5)
10500 JRST K.OERR ;(6) RIGHT HERE IN RIVER CITY
10600 JRST K.O1 ;(7) READY TO WRITE 'EM OUT
10700 0 ;(10) FILLED IN WITH FILE NAME
10800 SIXBIT /KNT/ ;(11) EXTENSION
10900 0 ;(12)
11000 0 ;(13)
11100 17 ;(14) DUMP MODE
11200 SIXBIT /DSK/ ;(15) DEVICE DISK
11300 0 ;(16) NO BUFFERS
11400
11500 K.OD2: OUT 0,1(2) ;(3) WRITE OUT COUNTERS
11600 JRST 6 ;(4) ALL OK
11700 JRST K.OERR ;(5) PROBLEMS
11800 RELEAS 0 ;(6) CLOSE FILE
11900 JRST K.O2 ;(7) GO BACK TO K.OUT
12000
12100 ENDCOM (KNT)
12200
12300 COMPIL(POW,<FPOW,POW,LOGS,FLOGS>,<X11,X33>,<POW, FPOW, LOGS, FLOGS -- EXPON. ROUTINES>)
00100
00200 DSCR BEGIN UTILS
00300 ⊗
00400 IFN ALWAYS,< BEGIN UTILS>
00500 COMMENT % EXPONENTIATION CODE
00600
00700 FPOW COMPUTES
00800 REAL←FPOW(REAL!BASE,INTEGER!EXPONENT)
00900
01000 POW COMPUTES
01100 REAL←POW(INTEGER!BASE,INTEGER!EXPONENT)
01200
01300 %
01400
01500 DSCR POW, FPOW, LOGS, FLOGS(EXPONENT,ARGUMENT). BOTH RETURN REALS.
01600 SID CLOBBERS LPSA,TEMP,USER
01700 CAL SAIL
01800 DES CALLS GENERATED BY COMPILER FOR ↑ OPERATOR
01900 ⊗
02000
02100 COMMENT !
02200 USER HAS THE BASE
02300 LPSA HAS THE EXPONENT
02400 TEMP HAS THE RESULT
02500
02600 !
02700
02800 HERE(FPOW)
02900 MOVE USER,-1(P) ;BASE
03000 SKIPGE LPSA,-2(P) ;EXPONENT -- IS IT NEGATIVE
03100 MOVN LPSA,LPSA ;NEGATE IT
03200 JUMPE LPSA,EXZERO ;0 EXPONENT
03300 MOVSI TEMP,(1.0) ;SET FOR FLOATING
03400 JRST 2,.+1 ;CLEAR AR FLAGS
03500
03600 FEXLUP:
03700 TRNE LPSA,1 ;COLLECT PRODUCT?
03800 FMPR TEMP,USER ;YES
03900 JOV FPOWOV ;OVERFLOW?
04000 ASH LPSA,-1 ;PREPARE TO LOOK AT NEXT BIT
04100 JUMPE LPSA,FEXDUN ;ALL DONE IF ZERO
04200 FMPR USER,USER ;SQUARE BASE
04300 JOV FPOWOV ;OVERFLOW?
04400 JRST FEXLUP
04500
04600 FEXDUN:
04700 SKIPGE -2(P) ;POSITIVE EXPONENT?
04800 JRST FEXDU1
04900 EXDUN: MOVE A,TEMP
05000 POWRET: SUB P,X33
05100 JRST @3(P)
05200
05300 EXZERO:
05400 SKIPN USER ;0↑0
05500 ERR <0↑0 NOT DEFINED>,1
05600 MOVSI A,(1.0) ;RETURN FLOATING 1
05700 JRST POWRET
05800
05900
06000 FEXDU1:
06100 ;MUST TAKE RECIPROCAL OF TEMP
06200 MOVSI A,(1.0)
06300 FDVR A,TEMP ;TAKE RECIPROCAL
06400 JRST POWRET ;RETURN
06500
06600 FPOWOV:
06700 ;ON AN OVERFLOW, WE FLOAT THE ARGUMENTS AND ATTEMPT
06800 ;TO USE THE FLOATING ROUTINES
06900 PUSH P, B ;SAVE B
07000 MOVE A,-2(P) ;BASE (ALREADY REAL)
07100 FLOAT B,-3(P) ;EXPONENT
07200 PUSH P,C ;SAVE C AND D
07300 PUSH P,D
07400 JRST TRYFL ;TRY THE FLOATING ARITHMETIC
07500
07600
07700 HERE(POW)
07800 MOVE USER,-1(P) ;BASE
07900 SKIPGE LPSA,-2(P) ;EXPONENT -- IS IT NEGATIVE
08000 MOVN LPSA,LPSA ;NEGATE IT
08100 JUMPE LPSA,EXZERO ;ZERO EXPONENT
08200 MOVEI TEMP,1
08300 JRST 2,.+1 ;CLEAR AR FLAGS
08400 EXPLUP:
08500 TRNE LPSA,1
08600 IMUL TEMP,USER
08700 JOV POWOV ;OVER (UNDER) FLOW
08800 ASH LPSA,-1
08900 JUMPE LPSA,FLORET ;ARE WE DONE?
09000 IMUL USER,USER
09100 JOV POWOV ;OVER (UNDER) FLOW
09200 JRST EXPLUP
09300
09400
09500 FLORET:
09600 IDIVI TEMP,1B18
09700 SKIPE TEMP
09800 TLC TEMP,254000
09900 TLC USER,233000
10000 FAD TEMP,USER ;FLOATED RESULT IN TEMP
10100 SKIPGE -2(P) ;POSITIVE EXPONENT?
10200 JRST FEXDU1 ;NO
10300 JRST EXDUN ;YES -- RETURN
10400
10500 POWOV:
10600 PUSH P,B ;SAVE B
10700 FLOAT A,-2(P) ;BASE
10800 FLOAT B,-3(P) ;EXPONENT
10900 PUSH P,C ;SAVE C AND D
11000 PUSH P,D
11100 JRST TRYFL
11200
00100 ;REAL←LOGS(INTEGER_BASE,REAL_EXPONENT)
00200 HERE(LOGS)
00300 PUSH P, B ;SAVE B
00400 MOVE A,-2(P) ;BASE
00500 ;DO FLOAT INLINE
00600 IDIVI A,1B18
00700 SKIPE A
00800 TLC A,254000
00900 TLC B,233000
01000 FAD A,B
01100
01200 MOVE B,-3(P) ;EXPONENT
01300 JRST FLOGS1 ;DO IT
01400
01500 ;REAL←FLOGS(REAL_BASE,REAL_EXPONENT)
01600
01700 HERE(FLOGS)
01800 PUSH P, B
01900 MOVE A,-2(P) ;BASE
02000 MOVE B,-3(P) ;EXPONENT
02100 JUMPE B, FLZERO ;EXIT IF EXPONENT IS ZERO
02200 FLOGS1: PUSH P, C ;SAVE MORE ACS
02300 PUSH P, D
02400
02500
02600 ;;; JUMPE A, FLZERO ;EXIT IMMEDIATELY IF BASE IS ZERO
02700
02800 SKIPGE D,B ;IS EXPONENT NEG. ?
02900 MOVNS D ;YES,MAKE IT POSITIVE
03000 MOVEI C,0 ;CLEAR AC C TO ZERO
03100 LSHC C,11 ;SHIFT 9 PLACES LEFT
03200 SUBI C,200 ;TO OBTAIN SHIFTING FACTOR
03300 JUMPLE C,EXP3GO ;IS C > 0
03400
03500 PUSH P,E ;SAVE E
03600 HRR E,C ;SET UP E AS AN INDEX REG.
03700 MOVEI C,0 ;CLEAR OUT AC C
03800 LSHC C,(E) ;SHIFT LFT BY CONTENTS OF E
03900 POP P,E ;RESTORE E
04000
04100 JUMPN D,EXP3GO ;IS EXPONENT AN INTEGER ?
04200 SKIPGE B ;YES, WAS IT NEG. ?
04300 MOVNS C ;YES, NEGATE IT
04400 PUSH P, B ;SAVE IT IN CASE WE NEED IT LATER
04500 MOVE B,C ;MOVE INTEGER INTO B
04600 PUSHJ P,EXP2.0 ;OBTAIN RESULT USING EXP2.0
04700 SUB P, X11 ;REMOVE B FROM STACK
04800 JRST EXP3A ;
04900 EXP3GO:
05000 ;ARGUMENT IS IN A
05100 TRYFL: PUSHJ P,ALOG ;CALCULATE LOG OF A
05200 FMPR A, B ;CALCULATE B*LOG(A)
05300 ;ARGUMENT IS IN A
05400 PUSHJ P,EXP ;CALCULATE EXP(B*LOG(A))
05500
05600 ;RESULT IS IN A
05700 EXP3A: POP P, D
05800 POP P, C
05900 POP P, B
06000 SUB P, X33
06100 JRST @3(P)
06200
06300 FLZERO:
06400 SKIPN A ;0↑0?
06500 ERR <0↑0 NOT DEFINED>,1
06600 POP P,B ;RESTORE B
06700 MOVSI A,(1.0) ;
06800 JRST POWRET ;RETURN
06900
07000
07100 COMMENT !
07200 EXP2.0 TAKES AS ARGUMENTS:
07300 A REAL
07400 B INTEGER
07500
07600 A↑B IS RETURNED IN A AS A REAL
07700 !
07800 OPDEF JRSTF [JRST 2,] ;IS THIS REALLY UNDEFINED IN FAIL?
07900
08000 EXP2.0: JUMPE A, BASEZ ;TREAT CASE OF A ZERO BASE
08100 PUSH P, C ;SAVE AC C
08200 MOVSI C, 201400 ;GET 1.0 IN ACCUMULATOR C
08300
08400 JRSTF @[XWD 0,.+1] ;CLEAR AR FLAGS
08500 JUMPGE B, GFEXP2 ;IS EXPONENT POSITIVE?
08600 MOVMS B ;NO, MAKE IT POSITIVE
08700 PUSHJ P, FEXP2 ;CALL MAIN PART OF PROGRAM
08800 MOVSI B, 201400 ;GET 1.0 IN B
08900 FDVM B, A ;FORM 1/(A**B) FOR NEG. EXPONENT
09000 RETEX2:
09100 POP P, C ;RESTORE C
09200 POPJ P, ;EXIT
09300
09400 GFEXP2: PUSHJ P,FEXP2 ;CALL FEXP2
09500 JRST RETEX2 ;RETURN
09600
09700 FEXP1: FMP A, A ;FORM A**N, FLOATING POINT
09800 LSH B, -1 ;SHIFT EXPONENT FOR NEXT BIT
09900 FEXP2: TRZE B, 1 ;IS THE BIT ON?
10000 FMP C, A ;YES, MULTIPLY ANSWER BY A**N
10100 JOV OVERF ;TRANSFER ON OVER (UNDER) FLOW
10200 JUMPN B, FEXP1 ;UPDATE A**N UNLESS ALL THROUGH
10300 FEXP3: MOVE A, C ;PICK UP RESULT FROM C
10400 FEXP4: POPJ P, ;EXIT
10500
10600 BASEZ: SKIPN B ;IS THE EXPONENT ALSO ZERO?
10700 ERR <0↑0 NOT DEFINED>
10800 MOVSI A,(1.0) ;1.0
10900 POPJ P,
11000
11100 COMMENT ! ROUTINE FOR OVERFLOW.
11200 This overflow trap occurs when we have tried to
11300 use EXP2.0. Instead, we will try to compute using logarithms.
11400
11500
11600 !
11700
11800 OVERF:
11900 SUB P, X11 ;REMOVE RETURN ADDRESS
12000 POP P, C ;RESTORE C
12100 SUB P, X11 ;REMOVE RETURN FROM EXP2.0
12200 POP P, B ;GET BACK REAL EXPONENT
12300 JRST TRYFL ;GO TRY FLOATING
12400
12500
12600
12700
12800 ;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION
12900 ;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE
13000 ; -88.028<X<88.028
13100 ;IF X<-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER
13200 ;IF X<88.028, THE PROGRAM RETURNS X AS THE ANSWER
13300 ;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS:
13400 ;EXP(X) = 2**(X*LOG(E)BASE2) = 2**(M+F)
13500 ;WHERE M IS AN INTEGER AND F IS A FRACTION
13600 ;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT
13700 ;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS
13800
13900 ;2**F = 2(0.5+F(A+B*F↑2 - F-C(F↑2 + D)**-1)**-1
14000
14100 ;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
14200 ; ARG IS IN ACCUMULATOR A
14300 ; PUSHJ P,EXP
14400 ;THE ANSWER IS RETURNED IN ACCUMULATOR A
14500
14600 EXP:
14700 PUSH P, B ;SAVE B
14800 MOVE B, A ;PICK UP THE ARGUMENT IN B
14900 MOVM A, B ;GET ABSF(X)
15000 CAMG A, E7 ;IS ARGUMENT IN PROPER RANGE?
15100 JRST EXP1 ;YES, GO TO ALGORITHM
15200 ;NON-FATAL MESSAGE
15300 ERR <EXPONENTIATION UNDER OR OVERFLOW>,1
15400 HRLOI A, 377777 ;GET LARGEST FLOATING NUMBER
15500 SKIPG B ;WAS THE ARGUMENT POSITIVE?
15600 MOVEI A, 0 ;NO, RETURN 0
15700 POP P, B ;RESTORE B
15800 POPJ P, ;RETURN
00100
00200 EXP1: PUSH P, C ;SAVE ACCUMULATOR C
00300 PUSH P, D ;SAVE ACCUMULATOR D
00400 PUSH P, E ;SAVE E
00500 PUSH P, LPSA ;SAVE LPSA
00600 SETZB E, LPSA ;INITIALIZE E, TBITS
00700 MULI B, 400 ;SEPARATE FRACTION AND EXPONENT
00800 TSC B, B ;GET A POSITIVE EXPONENT
00900 MUL C, E5 ;FIXED POINT MULTIPLY BY LOG2(E)
01000 ASHC C, -242(B) ;SEPARATE FRACTION AND INTEGER
01100 AOSG C ;ALGORITHM CALLS FOR MULT. BY 2
01200 AOS C ;ADJUST IF FRACTION WAS NEGATIVE
01300 HRRM C, LPSA ;SAVE FOR FUTURE SCALING
01400 ASH D, -10 ;MAKE ROOM FOR EXPONENT
01500 TLC D, 200000 ;PUT 200 IN EXPONENT BITS
01600 FADB D, E ;NORMALIZE, RESULTS TO D AND E
01700 FMP D, D ;FORM X↑2
01800 MOVE A, E2 ;GET FIRST CONSTANT
01900 FMP A, D ;E2*X↑2 IN A
02000 FAD D, E4 ;ADD E4 TO RESULTS IN D
02100 MOVE B, E3 ;PICK UP E3
02200 FDV B, D ;CALCULATE E3/(F↑2 + E4)
02300 FSB A, B ;E2*F↑2-E3(F↑2 + E4)**-1
02400 MOVE C, E ;GET F AGAIN
02500 FSB A, C ;SUBTRACT FROM PARTIAL SUM
02600 FAD A, E1 ;ADD IN E1
02700 FDVM C, A ;DIVIDE BY F
02800 FAD A, E6 ;ADD 0.5
02900 EX1: FSC A, (LPSA) ;SCALE THE RESULTS
03000 POP P, LPSA ;RESTORE ACS
03100 POP P, E
03200 POP P, D
03300 POP P, C
03400 POP P, B ;SAVED EARLIER
03500 POPJ P,
03600
03700
03800 E1: 204476430062 ;9.95459578
03900 E2: 174433723400 ;0.03465735903
04000 E3: 212464770715 ;617.97226953
04100 E4: 207535527022 ;87.417497202
04200 E5: 270524354513 ;LOG(E), BASE 2
04300 E6: 0.5
04400 E7: 207540071260 ;88.028
04500
04600
04700 ;ALOG
04800 ;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION
04900 ;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN
05000 ;ARGUMENT OF ZERO IS RETURNED AS MINUS INFINITY. THE ALGORITHM IS
05100
05200 ;LOGE(X) = (I + LOG2(F))*LOGE(2)
05300 ;WHERE X = (F/2)*2↑(I+1), AND LOG2(F) IS GIVEN BY
05400 ;LOG2(F) = C1*Z + C3*Z↑3 + C5*Z↑5 - 1/2
05500 ;AND Z = (F-SQRT(2))/(F+SQRT(2))
05600
05700 ;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:
05800 ;THE ARGUMENT IS IN ACCUMULATOR A
05900 ; PUSHJ P, ALOG
06000 ;THE ANSWER IS RETURNED IN ACCUMULATOR A
06100
06200
06300 ALOG:
06400 MOVM A, A ;GET ABSF(A)
06500 JUMPE A, LZERO ;CHECK FOR ZERO ARGUMENT
06600 CAMN A, ONE ;CHECK FOR 1.0 ARGUMENT
06700 JRST ZERANS ;IT IS 1.0 RETURN ZERO ANS.
06800 PUSH P, B ;SAVE AC B
06900 PUSH P, C ;SAVE AC C
07000 PUSH P, D ;SAVE AC D
07100 ASHC A, -33 ;SEPARATE FRACTION FROM EXPONENT
07200 ADDI A, 211000 ;FLOAT THE EXPONENT AND MULT. BY 2
07300 MOVSM A, C ;NUMBER NOW IN CORRECT FL. FORMAT
07400 MOVSI A, 567377 ;SET UP -401.0 IN A
07500 FADM A, C ;SUBTRACT 401 FROM EXP.*2
07600 ASH B, -10 ;SHIFT FRACTION FOR FLOATING
07700 TLC B, 200000 ;FLOAT THE FRACTION PART
07800 FAD B, L1 ;B = B-SQRT(2.0)/2.0
07900 MOVE A, B ;PUT RESULTS IN A
08000 FAD A, L2 ;A = A+SQRT(2.0)
08100 FDV B, A ;B = B/A
08200 MOVEM B, D ;STORE NEW VARIABLE IN D
08300 FMP B, B ;CALCULATE Z↑2
08400 MOVE A, L3 ;PICK UP FIRST CONSTANT
08500 FMP A, B ;MULTIPLY BY Z↑2
08600 FAD A, L4 ;ADD IN NEXT CONSTANT
08700 FMP A, B ;MULTIPLY BY Z↑2
08800 FAD A, L5 ;ADD IN NEXT CONSTANT
08900 FMP A, D ;MULTIPLY BY Z
09000 FAD A, C ;ADD IN EXPONENT TO FORM LOG2(X)
09100 FMP A, L7 ;MULTIPLY TO FORM LOGE(X)
09200 POP P, D ;RESTORE
09300 POP P, C
09400 POP P, B
09500 POPJ P, ;EXIT
09600
09700 LZERO: MOVE A, MIFI ;PICK UP MINUS INFINITY
09800 L: POPJ P, ;EXIT
09900
10000 ZERANS: MOVEI A, 0 ;MAKE ARG. ZERO
10100 POPJ P, ;EXIT
10200
10300 ;CONSTANTS
10400
10500 ONE: 201400000000
10600 L1: 577225754146 ;-0.707106781187
10700 L2: 201552023632 ;1.414213562374
10800 L3: 200462532521 ;0.5989786496
10900 L4: 200754213604 ;0.9614706323
11000 L5: 202561251002 ;2.8853912903
11100 L7: 200542710300 ;0.69314718056
11200 MIFI: 400000000001 ;LARGEST NEGATIVE FLOATING NUMBER
11300
11400 ENDCOM (POW)
11500
11600
11700 COMPIL(COD,<CODE,CALL>,<.SKIP.,CVSIX,X22,GOGTAB,X33>,<CODE, CALL>)
00100
00200 DSCR VAL←CODE(OCTAL COMMAND, REFERENCE ARG);
00300 ⊗
00400 Comment ⊗CODE
00500 Reference arg is added to octal command. CODAC(USER)
00600 is placed in AC 1. The constructed word is executed, and AC 1 resaved.
00700 Isn't that clever? (AC1 is also returned as the value of the call)
00800 ⊗
00900
01000 HERE (CODE) MOVE USER,GOGTAB
01100 SETOM .SKIP. ;ASSUME IT SKIPS
01200 PUSH P,0
01300 MOVE 1,CODAC(USER) ;GET USER'S AC
01400 MOVE 0,-3(P)
01500 ADDI 0,@-2(P) ;CALCULATE THE INSTR DO BE EXECUTED
01600 XCT 0 ;DO IT
01700 SETZM .SKIP. ;DIDN'T SKIP
01800 MOVEM 1,CODAC(USER)
01900 POP P,0
02000 SUB P,X33
02100 JRST @3(P)
02200
02300
02400 DSCR VALUE←CALL(VAL,"FUNCTION");
02500 CAL SAIL
02600 ⊗
02700
02800 ↑↑.CALL:
02900 HERE (CALL)
03000 SETOM .SKIP. ;ASSUME A SKIP
03100 PUSHJ P,CVSIX ;PARSE SIXBIT
03200 MOVE TEMP,A ;SIXBIT FOR WHAT'S WANTED
03300 MOVE A,-1(P) ;INPUT VALUE
03400 CALL A,TEMP
03500 SETZM .SKIP. ;NO SKIP, RECORD IT
03600 SUB P,X22 ;RETURN VALUE IN 1, WANT IT OR NOT
03700 JRST @2(P)
03800
03900 ENDCOM (COD)
04000
04100 IFN ALWAYS,<BEND UTILS>
04200 SUBTTL STRING HANDLING ROUTINES
04300
00100
00100
00200
00300
00400
00500
00600
00700
00100